VBA100本ノック 40本目:複数ブックの統合
指定フォルダ内のExcelブックから指定シートを集めてくる問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
「data」フォルダ内のExcelファイルについて、シート「2020年12月」のA1からの連続表範囲を集めます。※このシートが無いファイルもある。
自身の既存シート「2020年12月」に集めてください。
1行目は見出しなので2件目からは除く。
※ブック指定と「data」のパス位置は任意

VBA作成タイム
この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。
他の人の回答および解説を見て、書いたVBAを見直してみましょう。
頂いた回答
解説
フォルダ内のファイル取得は、100本ノックでも既出です。
今回はExcelファイルを開いてシート確認&データコピーが追加されたものです。
見出し行のコピー制御が若干面倒ですね。
Sub VBA100_40_01()
Const shtName = "2020年12月"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(shtName)
Dim sPath As String: sPath = wb.Path & "\data\"
Dim sFile As String
Dim wbT As Workbook, wsT As Worksheet
Dim outRow As Long, offsetRow As Long
ws.Cells.Clear
sFile = Dir(sPath & "*.xlsx")
Do While sFile <> ""
Set wbT = Workbooks.Open(FileName:=sPath & sFile, UpdateLinks:=0, ReadOnly:=True)
Set wsT = getWorksheet(wbT, shtName)
If Not wsT Is Nothing Then
outRow = ws.Range("A1").CurrentRegion.Rows.Count + offsetRow
wsT.Range("A1").CurrentRegion.Offset(offsetRow).Copy ws.Cells(outRow, 1)
offsetRow = 1
End If
wbT.Close SaveChanges:=False
sFile = Dir()
Loop
End Sub
Function getWorksheet(ByVal wb As Workbook, ByVal aName As String) As Worksheet
On Error Resume Next
Set getWorksheet = wb.Worksheets(aName)
End Function
ここは難しくはないのですが、どうしても記述が面倒になってしまうのは仕方ないように思います。
この辺りを少し記述を変えて、FSOを使った参考VBAを記事補足に掲載しました。
補足
再計算の停止については、読み込むファイルの事情(再計算が重い等)によって適宜対応してください。
On Errorを使って簡易に済ませています。
Sub VBA100_40_02()
Const shtName = "2020年12月"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(shtName)
Dim sPath As String: sPath = wb.Path & "\data"
Dim wbT As Workbook, wsT As Worksheet
Dim outRow As Long, offsetRow As Long
Dim objFso As Object, objFolder As Object, objFile As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(sPath)
Call setApp(False)
ws.Cells.Clear
outRow = 1
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Name) = "xlsx" Then
Set wbT = Workbooks.Open(FileName:=objFile.Path, UpdateLinks:=0, ReadOnly:=True)
Set wsT = getWorksheet(wbT, shtName)
If Not wsT Is Nothing Then
offsetRow = IIf(outRow = 1, 0, 1)
wsT.Range("A1").CurrentRegion.Offset(offsetRow).Copy ws.Cells(outRow, 1)
outRow = outRow + wsT.Range("A1").CurrentRegion.Rows.Count - offsetRow
End If
wbT.Close SaveChanges:=False
End If
Next
Call setApp(True)
End Sub
Function getWorksheet(ByVal wb As Workbook, ByVal aName As String) As Worksheet
On Error Resume Next
Set getWorksheet = wb.Worksheets(aName)
End Function
Sub setApp(ByVal arg As Boolean)
With Application
.Calculation = IIf(arg, xlCalculationAutomatic, xlCalculationManual)
.DisplayAlerts = arg
.ScreenUpdating = arg
End With
End Sub
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
37本目:グラフの色設定
38本目:1シートを複数シートに振り分け
39本目:数値リストの統合(マージ)
40本目:複数ブックの統合
41本目:暗算練習アプリ
42本目:データベース形式に変換
43本目:CSV出力
44本目:全テーブル一覧作成
45本目:テーブルに列追加
46本目:名前定義に使える文字
47本目:Window操作
新着記事NEW ・・・新着記事一覧を見る
新旧マスタの差異比較|Power Query(M言語)入門(2023-02-28)
有効な最新単価の取得|Power Query(M言語)入門(2023-02-26)
有効な最新単価の取得|Power Query(M言語)入門(2023-02-21)
グルーブ内の最小・最大|Power Query(M言語)入門(2023-02-17)
2つのテーブルのマージ|Power Query(M言語)入門(2023-02-15)
「売上」が数値の行のみ取り込む|Power Query(M言語)入門(2023-02-13)
A列のヘッダー名を変更する|Power Query(M言語)入門(2023-02-11)
CSVのA列が日付の行だけを取り込む|Power Query(M言語)入門(2023-02-10)
列数不定のCSVの取り込み|Power Query(M言語)入門(2023-02-09)
別ブックの最終シートの取り込み|Power Query(M言語)入門(2023-02-08)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.マクロって何?VBAって何?|VBA入門
7.並べ替え(Sort)|VBA入門
8.Excelショートカットキー一覧|Excelリファレンス
9.エクセルVBAでのシート指定方法|VBA技術解説
10.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 40本目:複数ブックの統合
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。