同じブックにまとめるやりかたと同じシートにまとめるやりかたを書いてます。
元々のソースはこのページ最下部にリンクを張っておきましたのでそちらをご参照ください。VBA初心者のｱﾀｸｼが細かいところでひっかかったので、自分にわかりやすいようにメモしたものなので。
↓
久々にやったらうまく動かなかったので、ChatGPT3.5先生に聞きながら修正しました。
修正したのは、以下の2つのコードです。
– 同じブックの同じシートに全てまとめる場合
– 同じブックの同じシートに全てまとめる場合-値のみ貼り付ける
同じブックの同じシートに全てまとめる場合
条件:
- 同じフォルダに基Excelファイルを配置する
- 基Excelファイルは閉じてる状態
- 貼り付け先のシート名は「Sheet1」とする。
Sub CopyDataAndFormatFromOtherWorkbooks()
Dim myPath As String
Dim fname As String
Dim AB As Workbook
Dim destSheet As Worksheet
Dim lastRowDest As Long
' 現在のワークブックのSheet1を指定します。必要に応じてシート名を変更してください。
Set destSheet = ThisWorkbook.Sheets("Sheet1")
' 現在のワークブックのパスを取得します
myPath = ThisWorkbook.Path & "\"
' フォルダ内のExcelファイルを検索します★拡張子が「.xls」になってるので、適宜「.xlsx」などに変更する
fname = Dir(myPath & "*.xls")
' ファイルが見つかる限り繰り返します
Do Until fname = ""
If fname <> ThisWorkbook.Name Then
' ファイルを開きます
Set AB = Workbooks.Open(myPath & fname)
' コピー元のシートを指定します。必要に応じてシート名を変更してください。
Dim sourceSheet As Worksheet
Set sourceSheet = AB.Sheets("★★コピー元のシート名。ここを変更する★★")
' コピー元のデータと書式をコピーします（1行目から6行目を除いて、全範囲）
Dim sourceRange As Range
Set sourceRange = sourceSheet.UsedRange.Offset(6, 0).Resize(sourceSheet.Rows.Count - 6, sourceSheet.Columns.Count)
' 貼り付け先の最終行を取得します
lastRowDest = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
' コピーしたデータと書式を貼り付けます
sourceRange.Copy
destSheet.Cells(lastRowDest + 1, 1).PasteSpecial xlPasteAll
' クリップボードに大きな情報がありますを表示させないためにクリップボードをクリアします
Application.CutCopyMode = False
' ファイルを閉じます
AB.Close SaveChanges:=False
End If
' 次のファイルを検索します
fname = Dir
Loop
End Sub
同じブックの同じシートに全てまとめる場合-値のみ貼り付ける
正式には、「値の貼り付け」を行いたい場合。
貼り付け元のデータがどこかのデータを参照（リンク）している場合、参照先がズレる場合があった。これでやるとリンク情報や書式はコピーされない。数値が見たままコピーされる。
貼り付け先のシート名は「Sheet1」とする。
Sub CopyDataFromOtherWorkbooks()
Dim myPath As String
Dim fname As String
Dim AB As Workbook
Dim lr As Long
Dim destSheet As Worksheet
' 現在のワークブックのSheet1を指定します。必要に応じてシート名を変更してください。
Set destSheet = ThisWorkbook.Sheets("Sheet1")
' 現在のワークブックのパスを取得します
myPath = ThisWorkbook.Path & "\"
' フォルダ内のExcelファイルを検索します★拡張子が「.xls」になってるので、適宜「.xlsx」などに変更する
fname = Dir(myPath & "*.xls")
' ファイルが見つかる限り繰り返します
Do Until fname = ""
If fname <> ThisWorkbook.Name Then
' ファイルを開きます
Set AB = Workbooks.Open(myPath & fname)
' コピー元のシートを指定します。必要に応じてシート名を変更してください。
Dim sourceSheet As Worksheet
Set sourceSheet = AB.Sheets("★★コピー元のシート名。ここを変更する★★")
' コピー元のデータをコピーします
sourceSheet.UsedRange.Copy
' コピーしたデータを貼り付けます
lr = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
destSheet.Cells(lr + 1, 1).PasteSpecial xlPasteValues
' クリップボードに大きな情報がありますを表示させないためにクリップボードをクリアします
Application.CutCopyMode = False
' ファイルを閉じます
AB.Close SaveChanges:=False
End If
' 次のファイルを検索します
fname = Dir
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参考にしたサイト
https://oshiete.goo.ne.jp/qa/1780042.html
http://www.moug.net/tech/exvba/0060003.html
ほぼ丸パクリです。
ありがとうございましたm(__)m
コメント