2021081903

Option Explicit

Sub 複数ブック1ブック化()
Application.ScreenUpdating = False ‘画面更新を一時停止

Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索

Do Until fname = Empty '全て検索
    If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
        Set WB = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
        WB.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く
        WB.Close (False) '保存の有無を聞かずに保存しないで閉じる
        n = n + 1 'ブック数をカウント
    End If

    fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す

Application.ScreenUpdating = True '画面更新一時停止を解除

MsgBox n & "件のブックをコピーしましました。"

End Sub

Sub 複数シート1シート化()
Dim sWS As Worksheet ‘データシート（コピー元）
Dim dWS As Worksheet ‘集約用シート（コピー先）

Set dWS = Worksheets("AllData")

'集約用シートの2行目以降を削除
dWS.UsedRange.Offset(1, 0).Clear

'各シートの2行目以降のデータを、集約用シートの末尾にコピー
For Each sWS In Worksheets
    If sWS.Name <> dWS.Name Then
        With sWS.UsedRange

            'コピー元シートにデータが1件以上ある場合
            If .Rows.Count > 1 Then
                .Offset(1, 0).Resize(.Rows.Count - 1).Copy _
                    Destination:=dWS.Cells(Rows.Count, 1). _
                                    End(xlUp).Offset(1, 0)
            End If

        End With
    End If
Next sWS

'集計用シートをA列で並べ替え
dWS.UsedRange.Sort Key1:=Range("A1"), Header:=xlYes

End Sub