複数のシートのデータを１つのシートにまとめるマクロ

#はじめに
私はプログラミングを勉強をはじめて
約1年半。

業務上複数あるシートを
１枚のシートにした上であれこれやる必要が生じた。
ただ、そのシートがあまりにも多すぎたし、
コピペするのも馬鹿馬鹿しくなったので
せっかくだから勉強してコードを書いてみた。

#状況
例えばこのような売上表(売上金額.xlsx)あったとする。

日付	売上金額
1/1	50,000
1/2	60,000
〜	〜
1/31	40,000

このシートは１月分で
2月から12月もそれぞれのシートで管理されていたりする。

この各月ごとに別れているシートを
1/1から12/31までつながったデータにしたい場合、

日付	売上金額
1/1	50,000
1/2	60,000
〜	〜
12/30	1,000,000
12/31	1,000

この程度ならば、
2月分をコピーし、1月の最下段に貼り付けを
12月まで繰り返せばできる。

あくまでこれは例の話だが、
このシートがたくさんある場合や、
日付などでなく連続性がない場合など
ヒューマンエラーも起りやすそうな作業となる。

#コード

Sub function()

　'画面更新停止
　Application.ScreenUpdating = False
  
  '確認ダイアログ停止
  Application.DisplayAlerts = False

  'コピー元になるブック
  Dim CopyWB As Workbook
  'コピー元になるシート
  Dim CopyWS As Worksheet
  '貼り付け用のシート
  Dim PasteWS As Worksheet
    
  'コピー元になるシートの最終行
  Dim max_row As Long
  'コピー元になるシートの最終列
  Dim max_column As Long
  
  '貼付用のシートの最終行
  Dim last_row As Long
  'もとになるシートの名前
  Dim OpenFileName As String
  
  '貼付用のシートはこのブックのsheet1
  Set PasteWS = ThisWorkbook.Sheets("sheet1")
  
  'ファイルを開くダイアログを表示
  OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")

  'キャンセルの時の処理
  If OpenFileName = "False" Then
    'メッセージ表示
    MsgBox "キャンセルされました"
    End
  
  Else

　　'貼付用シートを初期化
    dWS.Cells.Clear
    dWS.Cells.ClearFormats
    '元になるブック を開く
    Workbooks.Open OpenFileName
    Set CopyWB = ActiveWorkbook
    
  End If

  i = 0
  
  '元になるそれぞれのシートにおいて
  For Each CopyWS In CopyWB.Worksheets
    
    With CopyWS
   
      'CopyWSシートをアクティブに
      .Activate
      
      '最終行と列を求める
      max_row = .Range("A1").End(xlDown).Row
      max_column = .Range("A1").End(xlToRight).Column
      
      1枚目のシートの先頭行はそのまま張り付ける
      If i = 0 Then
      
        .Range(.Range("A1"), .Cells(4, max_column)).Copy
        PasteWS.Cells(1, 1).PasteSpecial (xlPasteAll)
        
      End If
      
      'A1セルから右下セルまでコピー
      .Range(.Cells(1, 1), .Cells(max_row, max_column)).Copy
      
      '貼り付け用シートの最下段を取得
      last_row = PasteWS.Cells(Rows.Count, 1).End(xlUp).Row
      
      
      '貼り付け
      PasteWS.Cells(last_row + 1, 1).PasteSpecial (xlPasteAll)
     
    End With
    
  Next sWS


  '元データを変更せずに閉じる
  Call sWB.Close(SaveChanges:=False)
  
  
  '貼付用シートをアクティブに
  dWS.Activate
  
　'A1セルに戻ってくる
  dWS.Range("A1").Activate
  ActiveWindow.ScrollRow = 1
  ActiveWindow.ScrollColumn = 1
  
End Sub

#まとめ
このマクロをもつエクセルファイルでから
この処理を実行すると、ファイルを開く画面が出る。
元となるデータのエクセルファイルを開くと、
各シートのデータをまとめて、
sheet1に書き出してくれる。
元データはそのまま閉じてしまうし、
A1セルがアクティブになった状態で、画面も表示されるようにしている。

簡単なところから自動化や単純化をすすめることで
普段の作業性UPやミスが減らせるので、
引き続きプログラミングの学習を進めていきます。

ありがとうございました。