エクセルの複数のシートを縦にまとめるエクセルVBAをご紹介します。
次のサンプルコードを使うと、
- 「ファイルを開く」ダイアログを表示。
- シートをまとめたいエクセルブックを選択。
- 選択したエクセルブックに、集約用シートを追加。
- エクセルブックに含まれる全シートをコピー、集約用シートにまとめる。
という作業を自動化します。
目次
処理イメージ
エクセルブック内にある複数シートをコピー、集約シートを追加して縦に貼り付けてまとめます。
操作方法
1、
下記サンプルコードを含むエクセルファイルを開き→「開発」→「マクロ」の順でクリック。
「Aシート縦に集約」→「実行」の順でクリック。
2、
ファイルを開くダイアログが表示されるので、シートをまとめたい対象のエクセルブックをクリックして、「開く」をクリック
3、
マクロが実行されます。
「集約シート」を追加、各シートをコピーして、
「集約シート」に各シートのデータを縦向きに貼り付けます。
完了です。
サンプルコード
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | Sub Aシート縦に集約() Dim sWS As Worksheet 'データシート Dim dWS As Worksheet '集約用シート Dim s_row As Long 'データシートの最終行数 Dim d_row As Long '集約用シートの最終行数 Dim OpenFileName As String 'ファイルを開くダイアログを表示 OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*") 'キャンセル時の処理 If OpenFileName = "False" Then 'メッセージ表示 MsgBox "キャンセルされました。処理を終了します。" End Else Workbooks.Open OpenFileName End If '画面更新停止 Application.ScreenUpdating = False '確認ダイアログ停止 Application.DisplayAlerts = False '集約シートがあるか確認 For Each sh In Sheets If sh.Name = "集約シート" Then flag = True Exit For End If Next sh If flag = True Then Dim rc As Integer 'メッセージ表示 rc = MsgBox("シート「集約シート」を上書きしますか？" & Chr(13) & "※この処理は戻せません", vbYesNo + vbQuestion, "確認") If rc = vbYes Then '画面更新停止 Application.ScreenUpdating = False 'シート選択 Worksheets("集約シート").Activate 'シート削除 ActiveSheet.Delete '画面更新停止 Application.ScreenUpdating = True 'メッセージ表示 MsgBox "処理前のシート「集約シート」は削除済みです" 'シート追加 Worksheets.Add before:=Worksheets(1) 'シート名変更 ActiveSheet.Name = "集約シート" 'シート選択 Worksheets("集約シート").Activate Set dWS = Worksheets("集約シート") 'ブックを上書き保存 ActiveWorkbook.Save '集約用シートの最終行数に1を代入 d_row = 1 '各シートにコードを実行 For Each sWS In Worksheets 'sWSとdWSのシート名が一致しない場合 If sWS.Name <> dWS.Name Then With sWS.UsedRange 'シートsWSをアクティブにする sWS.Activate 'シートの最終セルを選択する ActiveCell.SpecialCells(xlLastCell).Select '最終セルの行を取得、変数に代入 s_row = ActiveCell.row '最終行から1行目までを選択 Rows(1 & ":" & s_row).Select '最終行から1行目までをコピー Selection.Copy '集約用シートを選択 dWS.Activate '行を選択 Rows(d_row).Select 'コピーしたデータを貼り付け ActiveSheet.Paste 'シートの最終セルを選択する ActiveCell.SpecialCells(xlLastCell).Select '最終セルの行を取得、変数に代入 d_row = ActiveCell.Offset(1, 0).row End With End If Next sWS Else 'メッセージ表示 MsgBox "キャンセルされました。処理を終了します。" End If Else 'シート追加 Worksheets.Add before:=Worksheets(1) 'シート名変更 ActiveSheet.Name = "集約シート" 'シート選択 Worksheets("集約シート").Activate Set dWS = Worksheets("集約シート") '集約用シートのセルを全削除 Worksheets("集約シート").Cells.Select Selection.Delete Shift:=xlUp 'ブックを上書き保存 ActiveWorkbook.Save '集約用シートの最終行数に1を代入 d_row = 1 '各シートにコードを実行 For Each sWS In Worksheets 'sWSとdWSのシート名が一致しない場合 If sWS.Name <> dWS.Name Then With sWS.UsedRange 'シートsWSをアクティブにする sWS.Activate 'シートの最終セルを選択する ActiveCell.SpecialCells(xlLastCell).Select '最終セルの行を取得、変数に代入 s_row = ActiveCell.row '最終行から1行目までを選択 Rows(1 & ":" & s_row).Select '最終行から1行目までをコピー Selection.Copy '集約用シートを選択 dWS.Activate '行を選択 Rows(d_row).Select 'コピーしたデータを貼り付け ActiveSheet.Paste 'シートの最終セルを選択する ActiveCell.SpecialCells(xlLastCell).Select '最終セルの行を取得、変数に代入 d_row = ActiveCell.Offset(1, 0).row End With End If Next sWS End If End Sub |
コードの特徴
- 「ファイルを開く」ダイアログを表示した後、キャンセルをクリックした場合、
キャンセル処理される様に対応しています。 - セル、行、列に空白がある場合でも、
シート毎のデータが含まれる最終行からA行までをコピーして集約します。 - 集約用にシート「集約シート」を作成します。
同名シートが既にある場合、同名シートを削除するかの確認ダイアログを表示させ、
削除するかどうかを選択可能です。
