Excel VBA で同フォルダにあるBookの同名シートを一つのシートにまとめる

同じブックにまとめるやりかたと同じシートにまとめるやりかたを書いてます。

元々のソースはこのページ最下部にリンクを張っておきましたのでそちらをご参照ください。VBA初心者のｱﾀｸｼが細かいところでひっかかったので、自分にわかりやすいようにメモしたものなので。

同じブックの同じシートに全てまとめる場合
1. 同じブックの同じシートに全てまとめる場合-値のみ貼り付ける
同じブックでシートは別々にしてまとめる場合
参考にしたサイト

同じブックの同じシートに全てまとめる場合

条件:

同じフォルダに基Excelファイルを配置する
基Excelファイルは閉じてる状態



Sub Test()
myPath = ThisWorkbook.Path & "\"
fname = Dir(myPath & "*.xlsx") 'フォルダ内のExcelファイルを検索します

Do Until fname = Empty '全て検索し終えると、fname = Empty となるので、その間以下を実行します
If fname <> ThisWorkbook.Name Then
Workbooks.Open myPath & fname '選択したファイルを開きます
Set AB = ActiveWorkbook
lr = ThisWorkbook.Sheets("sheet1").Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

On Error Resume Next
AB.Sheets("★コピーしたいシート名").UsedRange.Copy
On Error GoTo 0
ThisWorkbook.Activate
Sheets("Sheet1").Range("A" & lr + 2).Select
ActiveSheet.Paste

'クリップボードに大きな情報がありますを表示させない対応
ActiveSheet.Range("A1").Copy

'Bookを閉じる
AB.Close
End If
fname = Dir '選択したフォルダ内の次のExcelファイルを検索します
Loop
End Sub

同じブックの同じシートに全てまとめる場合-値のみ貼り付ける

正式には、「値の貼り付け」を行いたい場合。
貼り付け元のデータがどこかのデータを参照（リンク）している場合、参照先がズレる場合があった。これでやるとリンク情報や書式はコピーされない。数値が見たままコピーされる。


Sub Test()
        myPath = ThisWorkbook.Path & "\"
        fname = Dir(myPath & "*.xlsx") 'フォルダ内のExcelファイルを検索します

        Do Until fname = Empty '全て検索し終えると、fname = Empty となるので、その間以下を実行します
                If fname <> ThisWorkbook.Name Then
                        Workbooks.Open myPath & fname '選択したファイルを開きます
                        Set AB = ActiveWorkbook
                        lr = ThisWorkbook.Sheets("sheet1").Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row


                        On Error Resume Next
                        AB.Sheets("★コピーしたいシート名").UsedRange.Copy
                        On Error GoTo 0
                        ThisWorkbook.Activate
                        'Sheets("Sheet1").Range("A" & lr + 2).Select
                        'ActiveSheet.Paste
                        Sheets("Sheet1").Range("A" & lr + 2).PasteSpecial (xlPasteValues)
                        

                        'クリップボードに大きな情報がありますを表示させない対応
                        ActiveSheet.Range("A1").Copy

                        'Bookを閉じる
                        AB.Close
                End If
                fname = Dir '選択したフォルダ内の次のExcelファイルを検索します
        Loop
End Sub

同じブックでシートは別々にしてまとめる場合

条件:

同じフォルダに基Excelファイルを配置する
基Excelファイルは閉じてる状態

Sub Sample()

'ここでシート名を指定して実行してね！
Const sheet_name As String = "★コピーしたいシート名"

Dim month_n As Integer
month_n = 3

Dim sFile As String
Dim sWB As Workbook, dWB As Workbook
Dim dSheetCount As Long
Dim i As Long
Const SOURCE_DIR As String = "D:\Documents\基になるエクセルファイル達が居るフォルダ\"
Const DEST_FILE As String = "D:\Documents\1つにまとめた結果ファイルを置くフォルダ\" & sheet_name & ".xlsx"

Application.ScreenUpdating = False

'指定したフォルダ内にあるブックのファイル名を取得
sFile = Dir(SOURCE_DIR & "*.xlsx")

'フォルダ内にブックがなければ終了
If sFile = "" Then Exit Sub

'集約用ブックを作成
Set dWB = Workbooks.Add

'集約用ブック作成時のシート数を取得
dSheetCount = dWB.Worksheets.Count

Do
'コピー元のブックを開く
Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

'コピー元の「報告書」シートを集約用ブックにコピー
sWB.Worksheets(sheet_name).Copy After:=dWB.Worksheets(dSheetCount)

'シート名をセルA1の値に変更
'ActiveSheet.Name = Range("A1").Value
ActiveSheet.Name = month_n

month_n = month_n - 1

If month_n <= 0 Then
month_n = 12
End If

'コピー元ファイルを閉じる
sWB.Close

'次のブックのファイル名を取得
sFile = Dir()
Loop While sFile <> ""

'集約用ブック作成時にあったシートを削除
Application.DisplayAlerts = False
For i = dSheetCount To 1 Step -1
dWB.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True

'集約用ブックを保存して閉じる
dWB.SaveAs Filename:=DEST_FILE
dWB.Close

Application.ScreenUpdating = False

MsgBox ("complete.")
End Sub