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

この記事から得るもの

他のBookへのCopy、Pasteする方法。
FSOを使用して、ファイルを開く。
Range．CurrentRegionの見出しを除いたデータをCopy、Pasteする方法。

目次
　 １　今回のお題
　 ２　今回のお題の意図
　 ３　回答
　 ４　感想　

１　今回のお題

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

excel-ubara.com

２　今回のお題の意図

１　該当するSheetが存在するかの確認。
２　最初のコピー時には見出しもコピーする。

３　回答

私の最初の回答

Sub ノック40本目_1()

'FSOを宣言
Dim fso_lord As Object: Set fso_lord = CreateObject("scripting.filesystemobject")

'pathの設定
wbPath = ThisWorkbook.Path & "\40本目\"

'ファイルをmyfilesにSetする。
Dim myfiles As Object: Set myfiles = fso_lord.getfolder(wbPath).Files

'主処理
Dim bookCount As Integer: bookCount = 0: Dim file As Object

For Each file In myfiles
    If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then
        'ファイルを開く
        Workbooks.Open wbPath & file.Name
        
        'Sheetに”2020年12月”があるか調べる。
        For Each sh In Sheets
            shCount = shCount + 1
            shCounts = Sheets.Count
            
            'Bookが１回目の書込み処理
            If sh.Name = "2020年12月" And bookCount = 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Copy
                
                'ファイルを閉じる
                Application.DisplayAlerts = False
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
                
                ActiveSheet.Paste Destination:=Range("A1")
                
                bookCount = bookCount + 1
                Exit For
            
            'Bookが２回目以降の書込み処理
            ElseIf sh.Name = "2020年12月" And bookCount > 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0).Copy
                
                'ファイルを閉じる
                Application.DisplayAlerts = False
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
                
                '最終行を取得
                lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Paste Destination:=Range("A" & lastRow)
                
                bookCount = bookCount + 1
                Exit For
                
            Else
                '"2020年12月"のSheetが無い場合はBookを閉じる。
                If shCount = Sheets.Count Then
                    'ファイルを閉じる
                    Application.DisplayAlerts = False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True
                End If
            End If
        Next
        
        '初期化
        shCount = 0
        
    End If
Next

End Sub

FSOを使って、フォルダをループします。
対象のBookが見つかったらBookを開いて、Copyした後に他のBookに貼り付ける手段がわからず、Copyして強制的に閉じる（クリップボードにデータは残っている）。その後、貼り付け元のSheetをActiveSheetとして貼り付けています。これに関してはもっといい方法がありそうです。

他のBOOKへのCopy ＆　Pasteについて

Sub copypaste()

'参考のコード
'wsT.Range("A1").CurrentRegion.Offset(offsetRow).Copy ws.Cells(outRow, 1)

Workbooks("A.xlsx").Worksheets("2020年12月").Range("A1").CurrentRegion.Copy Workbooks("40本目.xlsm").Worksheets("2020年12月").Range("A1")

End Sub

サイト管理者のコードを参考に記述してみました。
なるほど、他のBookへCopy ＆ Pasteするときは、「Workbook．Worksheet．Range」を指定してあげないといけないのですね。
こういう基本的な部分がまだまだ甘い(;^ω^)

私の最終回答

Sub ノック40本目_2()

Const SheetName = "2020年12月"

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(SheetName)

'書込み先データの削除
wb.Worksheets(SheetName).Cells.Clear

'FSOを宣言
Dim fso_lord As Object: Set fso_lord = CreateObject("scripting.filesystemobject")

'pathの設定
wbPath = ThisWorkbook.Path & "\40本目\data\"

'ファイルをmyfilesにSetする。
Dim myfiles As Object: Set myfiles = fso_lord.getfolder(wbPath).Files

'主処理
Dim bookCount As Integer: bookCount = 0: Dim file As Object

For Each file In myfiles
    If Not file.Name Like "~$*" Or file.Name Like ".xlsx" Then
        'ファイルを開く
        Workbooks.Open wbPath & file.Name
        
        'Sheetに”2020年12月”があるか調べる。
        For Each sh In Sheets
            shCount = shCount + 1
            shCounts = Sheets.Count
            
            'Bookが１回目の書込み処理
            If sh.Name = "2020年12月" And bookCount = 0 Then
                Worksheets(sh.Name).Select
                ActiveSheet.Range("A1").CurrentRegion.Copy ws.Range("A1")
                
                'ファイルを閉じる
                ActiveWorkbook.Close SaveChanges:=False
                
                '処理済みBook数をインクリメント
                bookCount = bookCount + 1
                Exit For
            
            'Bookが２回目以降の書込み処理
            ElseIf sh.Name = "2020年12月" And bookCount > 0 Then
                Worksheets(sh.Name).Select
                
                '最終行を取得して貼り付け
                lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0).Copy ws.Range("A" & lastRow)
                
                'ファイルを閉じる
                ActiveWorkbook.Close SaveChanges:=False
                
                '処理済みBook数をインクリメント
                bookCount = bookCount + 1
                Exit For
                
            Else
                '"2020年12月"のSheetが無い場合はBookを閉じる。
                If shCount = Sheets.Count Then
                
                    'ファイルを閉じる
                    ActiveWorkbook.Close SaveChanges:=False
                End If
            End If
        Next
        
        '初期化
        shCount = 0
        
    End If
Next


End Sub

Copy、Pasteを簡潔に記述しました。変数wsにBook名とSheet名をSetしておけば、楽にPaste時に使用できます。
ファイルを閉じる処理も、「SaveChanges:=False」を加えることで、Application.DisplayAlertsをいじる必要もなくなります。

４　感想

今回もかなり勉強になりました。他のBookへCopy、Pasteする方法は知っておかないといけないですね(;^ω^)
「Range（”A1”）．CurrentRegion.Offset(1, 0).Copy」で見出しを除いたデータ部をCopyする方法もかなり便利です。

ひとつ気になったのは、定数で指定している”2020年12月”は大文字の可能性もあるので、strconv関数で半角文字にしてしてあげるとよりよいのかなと思いました。

ではでは、この辺で(^^)/~~~