Excelデータ表を特定の項目ごとに分類して複数シートに表を作成する

2022年8月14日

以下のようにあるシートのデータ表を複数のシートに振り分けて表を作成する場合、
VBAを使うとボタンをワンクリックするだけで作業を完了させることができます。

やり方としてはVBAで次のように各シートの定義とオブジェクトを作成して
作成したオブジェクトに対して操作します。

 ’ワークシート変数の定義
  Dim Ws1, Ws2, Ws3, Ws4 As Worksheet
 ’Worksheetオブジェクトを取得
  Set Ws1 = Worksheets(“通勤手当一覧")
  Set Ws2 = Worksheets(“東京")
  Set Ws3 = Worksheets(“埼玉")
  Set Ws4 = Worksheets(“新潟")

具体的なコードの記述方法は下記「サンプルコードの処理内容」及び「サンプルコード」参照ください。
また、Worksheetオブジェクトのメソッドとプロパティ一覧については下記リンク先を参照ください。

  Worksheetオブジェクト メソッド/プロパティ一覧

サンプルアプリ実行動作

「データを各シートに振り分け」ボタンをクリックすると
上記で説明したように該当シートにデータが振り分けられ表が作成されます。

サンプルコードの処理内容

処理の内容については以下の通りです。

各種変数の定義
     ↓
各ワークシートオブジェクトの取得
     ↓
既存データの削除
     ↓
各シートに表項目行をコピー
     ↓
元データの勤務地を確認しながら該当シートにデータをコピー (ループ処理)
     ↓
元データシートのA1セルを選択
     ↓
処理完了メッセージの表示

サンプルコード    アプリの作成手順はこちら

Option Explicit

Sub データ振り分け()

  '行カウント変数の定義
   Dim i As Integer
  '各シートのデータ最終行番号を入れる変数の定義
   Dim Ws1End, Ws2End, Ws3End, Ws4End As Integer
  'ワークシート変数の定義
   Dim Ws1, Ws2, Ws3, Ws4 As Worksheet
  
 'Worksheetオブジェクトを取得  
   Set Ws1 = Worksheets("通勤手当一覧")
   Set Ws2 = Worksheets("東京")
   Set Ws3 = Worksheets("埼玉")
   Set Ws4 = Worksheets("新潟")

'既存のデータを削除

  '東京シート
    '既存データの最終行の取得
     Ws2End = Ws2.Cells(Rows.Count, 2).End(xlUp).Row
    
    '既存データがあったらデータ削除
     If Ws2End > 5 Then
       Ws2.Range("B5:G" & Ws2End).Delete Shift:=xlShiftUp
     End If

  '埼玉シート
   '既存データの最終行の取得
    Ws3End = Ws3.Cells(Rows.Count, 2).End(xlUp).Row
    
   '既存データがあったらデータ削除
    If Ws3End > 5 Then
      Ws3.Range("B5:G" & Ws3End).Delete Shift:=xlShiftUp
    End If

  '新潟シート
   '既存データの最終行の取得
    Ws4End = Ws4.Cells(Rows.Count, 2).End(xlUp).Row
       
   '既存データがあったらデータ削除
    If Ws4End > 5 Then
      Ws4.Range("B5:G" & Ws4End).Delete Shift:=xlShiftUp
    End If


'各シートに表の項目行をコピー
  
  '東京シートに項目行をコピー
   Ws1.Range("B5:G5").Copy Ws2.Range("B5")
  
  '埼玉シートに項目行をコピー
   Ws1.Range("B5:G5").Copy Ws3.Range("B5")

  '新潟シートに項目行をコピー
   Ws1.Range("B5:G5").Copy Ws4.Range("B5")


'各シートにデータコピー

  '振り分け元データの先頭位置設定
   i = 6
  '振り分け元データの最終行の位置取得
   Ws1End = Ws1.Cells(Rows.Count, 2).End(xlUp).Row

  '振り分け元データの勤務地を確認しながら該当するシートにデータをコピー
  
  '振り分け元データの6行目からデータ最終行までループ処理
   For i = 6 To Ws1End
   
   '勤務地名に「東京」が入っていたら
    If InStr(Ws1.Cells(i, 6), "東京") > 0 Then
    
     '「東京」シートのデータ最終行を取得する
      Ws2End = Ws2.Cells(Rows.Count, 2).End(xlUp).Row
     '元データを「東京」シートにコピーする
      Ws1.Range("B" & i & ": G" & i).Copy Ws2.Range("B" & Ws2End + 1 & ": G" & Ws2End + 1)
    
   '勤務地名に「埼玉」が入っていたら
    ElseIf InStr(Ws1.Cells(i, 6), "埼玉") > 0 Then
   
     '「埼玉」シートのデータ最終行を取得する
      Ws3End = Ws3.Cells(Rows.Count, 2).End(xlUp).Row
     '元データを「埼玉」シートにコピーする
      Ws1.Range("B" & i & ": G" & i).Copy Ws3.Range("B" & Ws3End + 1 & ": G" & Ws3End + 1)
      
   '勤務地名に「新潟」が入っていたら
    ElseIf InStr(Ws1.Cells(i, 6), "新潟") > 0 Then
   
     '「新潟」シートのデータ最終行を取得する
      Ws4End = Ws4.Cells(Rows.Count, 2).End(xlUp).Row
     '元データを「新潟」シートにコピーする
      Ws1.Range("B" & i & ": G" & i).Copy Ws4.Range("B" & Ws4End + 1 & ": G" & Ws4End + 1)
   
    End If
   
   Next
       
 '「通勤手当一覧」シートのA1セルを選択して終了する
  Ws1.Range("A1").Select

 '処理完了メッセージの表示
  MsgBox "処理が完了しました。"