Option Explicit
Sub 削除()
Dim ans As Integer
ans = MsgBox("「" & ActiveSheet.Name & "」以外のシートを削除しますか？", vbOKCancel, "削除確認")
If ans = vbCancel Then Exit Sub
Dim targetSheet As Worksheet '繰り返し用
'警告メッセージを表示しない
Application.DisplayAlerts = False
'削除処理
For Each targetSheet In Worksheets
If targetSheet.Name <> ActiveSheet.Name Then
targetSheet.Delete
End If
Next
'警告メッセージを表示
Application.DisplayAlerts = True
End Sub
Function シート存在チェック(strSheetName As String)
Dim objWorksheet As Worksheet
On Error GoTo NotExists
Set objWorksheet = ActiveWorkbook.Sheets(strSheetName)
シート存在チェック = True
Exit Function
NotExists:
シート存在チェック = False
End Function
Function 値が入っているかチェック(nullSheet As Worksheet)
On Error GoTo NoExists
Dim wTarget As Range
'SpecialCellsで取得したセルの参照をワーク領域へ保存
Set wTarget = nullSheet.Cells.SpecialCells(xlCellTypeConstants)
値が入っているかチェック = True
Exit Function
NoExists:
値が入っているかチェック = False
End Function
Sub まとめる()
Dim sFile As String
Dim sWB As Workbook
Dim dWS As Worksheet
Dim dl_Dir As String
Dim SOURCE_DIR As String
Dim flg As Long
Dim Maxrow As Long
Dim lRow As Long 'データ最終行取得変数
Dim lCol As Long 'データ最終列取得変数
Dim lRow2 As Long 'データ最終行取得変数2
Dim sSheetName As String
Dim dSheetName As String
Dim TitleRows As String
Dim j As Long
Dim CworkS As Boolean 'Loopの終了判定(シート存在チェック)
sSheetName = Cells(5, 4).Value
TitleRows = Cells(8, 4).Value
If sSheetName = "" Then
MsgBox "シート名を入力してください"
Exit Sub
ElseIf TitleRows = "" Then
MsgBox "見出し行の数を入力してください"
Exit Sub
End If
Application.ScreenUpdating = False '更新非表示
Cells(2, 4).ClearContents
'ダイアログでフォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択して下さい"
If .Show = False Then Exit Sub
dl_Dir = .SelectedItems(1)
End With
SOURCE_DIR = dl_Dir & "\"
'指定したフォルダ内にあるブックのファイル取得
sFile = Dir(SOURCE_DIR & "*.xls*")
'フォルダ内にブックがなければ終了
If sFile = "" Then Exit Sub
'集約用シートを作成
Worksheets.Add After:=Worksheets(1)
Set dWS = Worksheets(2)
dSheetName = sSheetName
CworkS = シート存在チェック(dSheetName)
j = 0
Do While CworkS
'重複したworksheetがある場合、(1), (2), ...と連番をつけて,
'更に重複が無いか調べてない場合はWorksheet名として適用する。
j = j + 1 '連番用の変数
'シート名の再設定
dSheetName = sSheetName & "(" & j & ")"
CworkS = シート存在チェック(dSheetName)
Loop
dWS.Name = dSheetName
flg = 0
Do
Application.DisplayAlerts = False
Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile, ReadOnly:=True)
Application.DisplayAlerts = True
'★アラートの表示状況により位置を変える
If シート存在チェック(sSheetName) Then
'シート再表示
Sheets(sSheetName).Visible = True
Sheets(sSheetName).Select
If flg = 0 And TitleRows >= 1 Then
'列見出しをコピー
lCol = sWB.Worksheets(sSheetName).UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
sWB.Worksheets(sSheetName).Range(Cells(1, 1), Cells(TitleRows, lCol)).Copy
dWS.Range("B1").PasteSpecial Paste:=xlPasteValues
dWS.Range("B1").PasteSpecial Paste:=xlPasteFormats
dWS.Range("B1").PasteSpecial Paste:=xlPasteComments
Application.CutCopyMode = False
End If
sWB.Activate
With Worksheets(sSheetName)
lRow = .UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
lCol = .UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
'シートのデータがTitleRows行以上の場合にコピー
If lRow > TitleRows Then
dWS.Activate
If 値が入っているかチェック(dWS) = True Then
lRow2 = dWS.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row + 1
Else
lRow2 = 1
End If
.Activate
.Range(Cells(TitleRows + 1, 1), Cells(lRow, lCol)).Copy
dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteValues
dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteFormats
dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteComments
Application.CutCopyMode = False
dWS.Activate
Maxrow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
dWS.Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Value = sWB.Name
If flg Mod 2 = 0 Then
Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Interior.ColorIndex = 37
Else
Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Interior.ColorIndex = 36
End If
End If
End With
End If
'コピー元ファイルを閉じる
sWB.Close SaveChanges:=False
'次のブックのファイル名を取得
sFile = Dir()
flg = flg + 1
Loop While sFile <> ""
ThisWorkbook.Sheets(1).Cells(2, 4) = dl_Dir
If 値が入っているかチェック(dWS) = True Then
MsgBox "「" & dSheetName & "」シートが作成されました"
Else
'シート名のミスなどで該当データがなければシートを削除してメッセージを表示
Application.DisplayAlerts = False
dWS.Delete
Application.DisplayAlerts = True
ThisWorkbook.Sheets(1).Activate
MsgBox "「" & sSheetName & "」シートのデータが見つかりませんでした" & vbNewLine & "フォルダとシート名に間違いがないか確認してください"
End If
Application.ScreenUpdating = True '更新表示
End Sub
