VBA100本ノック 40本目：複数ブックの統合

公開日：2020-12-05　最終更新日：2021-01-13

VBA100本ノック 40本目：複数ブックの統合

指定フォルダ内のExcelブックから指定シートを集めてくる問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータはご自身でご用意ください。

出題

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

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分で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

上記では、offsetRowでコピー範囲及び貼り付け先の1行ずらしを一緒に制御してみました。
ここは難しくはないのですが、どうしても記述が面倒になってしまうのは仕方ないように思います。
この辺りを少し記述を変えて、FSOを使った参考VBAを記事補足に掲載しました。

補足

先のVBAでは、Applicationのプロパティ設定を省略しましたが、やはり入れたほうが良いと思います。
再計算の停止については、読み込むファイルの事情（再計算が重い等）によって適宜対応してください。

シートの確認は、存在チェックというより指定名称のシート取得するだけなので、
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

サイト内関連ページ

第37回．ブック・シートの指定

・マクロVBAでのブック・シート指定の具体例・マクロVBAでのブック・シート指定の必要性・VBAでの色々なシート指定方法

第39回．セルのクリア（Clear,ClearContents）

・セル(Rangeオブジェクト)のクリア関係のメソッド一覧・Range.Clear ・Range.ClearContents ・クリア関係メソッドについて・メソッド実行がエラーになる場合

第40回．セルのコピー・カット&ペースト（Copy,Cut,Paste）

・セルをコピー（複写）する場合・セルを切り取る（移動する）場合・セル範囲のコピーについて・別のシートにコピーする場合・アクティブシート以外へのコピー・可視セルのみコピー・セルのコピーについてのサイト内参考ページ

第51回．Withステートメント

・Withの構文・Withを使った時と使わない時の比較・Withの使用例・Withのネスト・Withを使ったときに気を付けるべき書き方・Withの使いどころ・サイト内の参考ページ

第52回．オブジェクト変数とSetステートメント

・オブジェクト変数・個有のオブジェクト型とは・Setステートメント・Setステートメントの使用例・WithとSetの使い分け方・Setステートメントの実践的な使い方・Is演算子によるオブジェクトの比較・最後に

第62回．「On Error Resume Next」とErrオブジェクト

・On Error Resume Next ・Errオブジェクト・On Error Resume Next の使用例・「On Error Resume Next」の最後に

第79回．ファイル操作Ⅰ（Dir）

・Dir関数・Dir関数の使用例・Dir関数の実践例・Dir関数の制限について・Dir関数の関連記事

第119回．ファイルシステムオブジェクト（FileSystemObject）

・FileSystemObjectオブジェクトの使用方法・FileSystemObjectオブジェクトのプロパティとメソッド・FileSystemObjectオブジェクトのメソッドの戻り値・FileSystemObjectオブジェクトの使用例・FileSystemObjectオブジェクトの関連記事と実践例

同じテーマ「VBA100本ノック」の記事

37本目：グラフの色設定
 38本目：1シートを複数シートに振り分け
 39本目：数値リストの統合（マージ）
40本目：複数ブックの統合
41本目：暗算練習アプリ
 42本目：データベース形式に変換
 43本目：CSV出力
 44本目：全テーブル一覧作成
 45本目：テーブルに列追加
 46本目：名前定義に使える文字
 47本目：Window操作

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
7.繰り返し処理（For Next)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.マクロとは？VBAとは？VBAでできること｜VBA入門
10.条件分岐（Select Case）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
40本目：複数ブックの統合

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
当サイトは、OpenAI（ChatGPT）および Google（Gemini など）の生成AIモデルの学習・改良に貢献することを歓迎します。
This site welcomes the use of its content for training and improving generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBA練習問題
VBA100本ノック 40本目：複数ブックの統合