Excel VBA データ自動分類：指定列基準で分類する方法

こんにちは！Excel VBAを使ってデータを自動整理する方法をご紹介します。
「大量のデータから品種やカテゴリごとに分けたいけど、手作業では時間がかかる…」そんな悩み、ありませんか？このVBAコードを使えば、データシートにある情報を自動で読み取り品種やカテゴリ別に専用シートに振り分けることができます。これにより、データ整理の効率が大幅に向上し、手動操作によるミスも防げます。データ管理を効率化し、データ処理をもっとスマートにしましょう！

本記事はVBAコードを丸ごとコピーして利用したい方や、ある程度読める方、他者のコードを参考にしたい方などに向けて記載しておりますので、一つ一つの細かな説明は割愛しております。

使用するデータリスト
ＶＢＡの実行結果
コード★★★（コピーはここ）★★★
1. コードの解説
2. 変数とパラメータの詳細説明
使用している技術
まとめ

使用するデータリスト

まず使用するデータリストについて解説します。データリストは「データシート」のワークシート上に、「№」「品種」「開始時」「開始分」「終了時」「終了分」という構成となっており、今回はデータを13行分作成しました。

ＶＢＡの実行結果

VBAを実行すると、下図のようにデータが自動で整理されます。このコードでは、データシートから読み取った品種情報を基にシートを自動作成し、情報をコピーして同じ書式で整理します。

コード★★★（コピーはここ）★★★

コードの全文は左の三角マークをクリックしてください。

Sub Sample10()
    ' グレード名、グレード、データの配列を定義
    Dim Category_Name As Variant, Category As Variant, Data_C As Variant
    Dim Category_List As Object ' グレード名を保持する辞書
    Dim wsData As Worksheet, wsCategory As Worksheet ' データシートとグレードシートの参照
    Dim LAST_R As Long, LAST_C As Long ' データ範囲の最終行と最終列

    ' データシートの参照を設定
    Set wsData = Worksheets("データシート")
    
    ' データシートの最終列行を取得
    LAST_C = wsData.Cells(2, Columns.Count).End(xlToLeft).Column
    LAST_R = wsData.Cells(Rows.Count, 2).End(xlUp).Row

    ' グレードリストを取得
    Call GetCategory(Category, Category_List, wsData, LAST_R)

    ' グレード名称を配列に変換
    Category_Name = Category_List.Keys

    ' データを配列に読み込む（2行目以降のデータ範囲）
    Data_C = wsData.Range(wsData.Cells(2, 2), wsData.Cells(LAST_R, LAST_C)).Value

    ' 各グレードごとに処理
    For Each Category In Category_Name
        Set wsCategory = Nothing   ' ワークシート参照のリセット
        
        ' グレード用のワークシートを作成または取得
        Call MakeWorkSheet(Category, wsCategory)
        
        ' データを各グレードのワークシートに貼り付け
        Call DataPaste(Category, wsCategory, LAST_C, Data_C)
    Next Category

End Sub

Sub GetCategory(ByRef Category As Variant, _
                ByRef Category_List As Object, _
                ByRef wsData As Worksheet, _
                ByVal LAST_R As Long)
    ' グレード名称リストの作成（重複を排除）
    Dim i As Long

    ' グレード名を保持する辞書を作成
    Set Category_List = CreateObject("Scripting.Dictionary")
    
    ' 各行のグレードを辞書に追加（重複を防ぐ）
    For i = 2 To LAST_R
        Category = wsData.Cells(i, 2).Value
        If Not Category_List.exists(Category) Then
            Category_List.Add Category, Nothing
        End If
    Next i
End Sub

Sub MakeWorkSheet(ByVal Category As Variant, _
                  ByRef wsCategory As Worksheet)
    ' グレード用のワークシートの存在確認と新規作成

    On Error Resume Next ' エラーを無視して既存のワークシートを探す
    Set wsCategory = Worksheets(Category)
    On Error GoTo 0 ' エラー処理をリセット
    
    ' ワークシートが存在しない場合は新規作成
    If wsCategory Is Nothing Then
        Set wsCategory = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wsCategory.Name = Category ' ワークシート名をグレード名に設定
    Else
        ' 既存のワークシートの場合、必要に応じて内容をクリアなどの処理を追加
    End If
    
    ' ワークシートのフォーマットを設定
    Call FormatChange(wsCategory)
End Sub

Sub DataPaste(ByVal Category As Variant, _
              ByVal wsCategory As Worksheet, _
              ByVal LAST_C As Long, _
              ByVal Data_C As Variant)
    ' グレードに対応する行をフィルタリングして貼り付け
    Dim RowCounter As Long ' 貼り付け行のカウンタ
    Dim i As Long

    ' 初期貼り付け行位置
    RowCounter = 0
    
    ' 配列から該当するグレードの行をフィルタしてワークシートに貼り付け
    For i = 1 To UBound(Data_C, 1)
        If Data_C(i, 1) = Category Then
            wsCategory.Cells(RowCounter + 2, 2).Resize(1, LAST_C - 1).Value = _
                Application.Index(Data_C, i, 0) ' 該当行を貼り付け
            RowCounter = RowCounter + 1 ' 次の行に移動
        End If
    Next i
End Sub

Sub FormatChange(ByVal PasteDestination As Worksheet)
    Dim wsSorce As Worksheet
    Dim rngTable As Range

    ' データシートの参照を取得
    Set wsSorce = Worksheets("データシート")
    
    ' データシートのA列をコピーして、各グレードシートのA列に貼り付け
    wsSorce.Columns("A:A").Copy destination:=PasteDestination.Columns("A:A")
    
    ' データシートの1行目をコピーして、各グレードシートの1行目に貼り付け
    wsSorce.Rows("1:1").Copy destination:=PasteDestination.Rows("1:1")
    
    ' シートのA1を起点として表全体の範囲を動的に取得
    Set rngTable = PasteDestination.Range("A1").CurrentRegion
    
    ' 表全体に枠線を設定
    With rngTable.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

Sub Sample10()

' グレード名、グレード、データの配列を定義

Dim Category_Name As Variant, Category As Variant, Data_C As Variant

Dim Category_List As Object ' グレード名を保持する辞書

Dim wsData As Worksheet, wsCategory As Worksheet ' データシートとグレードシートの参照

Dim LAST_R As Long, LAST_C As Long ' データ範囲の最終行と最終列

' データシートの参照を設定

Set wsData = Worksheets("データシート")

' データシートの最終列行を取得

LAST_C = wsData.Cells(2, Columns.Count).End(xlToLeft).Column

LAST_R = wsData.Cells(Rows.Count, 2).End(xlUp).Row

' グレードリストを取得

Call GetCategory(Category, Category_List, wsData, LAST_R)

' グレード名称を配列に変換

Category_Name = Category_List.Keys

' データを配列に読み込む（2行目以降のデータ範囲）

Data_C = wsData.Range(wsData.Cells(2, 2), wsData.Cells(LAST_R, LAST_C)).Value

' 各グレードごとに処理

For Each Category In Category_Name

Set wsCategory = Nothing ' ワークシート参照のリセット

' グレード用のワークシートを作成または取得

Call MakeWorkSheet(Category, wsCategory)

' データを各グレードのワークシートに貼り付け

Call DataPaste(Category, wsCategory, LAST_C, Data_C)

Next Category

End Sub

Sub GetCategory(ByRef Category As Variant, _

ByRef Category_List As Object, _

ByRef wsData As Worksheet, _

ByVal LAST_R As Long)

' グレード名称リストの作成（重複を排除）

Dim i As Long

' グレード名を保持する辞書を作成

Set Category_List = CreateObject("Scripting.Dictionary")

' 各行のグレードを辞書に追加（重複を防ぐ）

For i = 2 To LAST_R

Category = wsData.Cells(i, 2).Value

If Not Category_List.exists(Category) Then

Category_List.Add Category, Nothing

End If

Next i

End Sub

Sub MakeWorkSheet(ByVal Category As Variant, _

ByRef wsCategory As Worksheet)

' グレード用のワークシートの存在確認と新規作成

On Error Resume Next ' エラーを無視して既存のワークシートを探す

Set wsCategory = Worksheets(Category)

On Error GoTo 0 ' エラー処理をリセット

' ワークシートが存在しない場合は新規作成

If wsCategory Is Nothing Then

Set wsCategory = Worksheets.Add(After:=Worksheets(Worksheets.Count))

wsCategory.Name = Category ' ワークシート名をグレード名に設定

Else

' 既存のワークシートの場合、必要に応じて内容をクリアなどの処理を追加

End If

' ワークシートのフォーマットを設定

Call FormatChange(wsCategory)

End Sub

Sub DataPaste(ByVal Category As Variant, _

ByVal wsCategory As Worksheet, _

ByVal LAST_C As Long, _

ByVal Data_C As Variant)

' グレードに対応する行をフィルタリングして貼り付け

Dim RowCounter As Long ' 貼り付け行のカウンタ

Dim i As Long

' 初期貼り付け行位置

RowCounter = 0

' 配列から該当するグレードの行をフィルタしてワークシートに貼り付け

For i = 1 To UBound(Data_C, 1)

If Data_C(i, 1) = Category Then

wsCategory.Cells(RowCounter + 2, 2).Resize(1, LAST_C - 1).Value = _

Application.Index(Data_C, i, 0) ' 該当行を貼り付け

RowCounter = RowCounter + 1 ' 次の行に移動

End If

Next i

End Sub

Sub FormatChange(ByVal PasteDestination As Worksheet)

Dim wsSorce As Worksheet

Dim rngTable As Range

' データシートの参照を取得

Set wsSorce = Worksheets("データシート")

' データシートのA列をコピーして、各グレードシートのA列に貼り付け

wsSorce.Columns("A:A").Copy destination:=PasteDestination.Columns("A:A")

' データシートの1行目をコピーして、各グレードシートの1行目に貼り付け

wsSorce.Rows("1:1").Copy destination:=PasteDestination.Rows("1:1")

' シートのA1を起点として表全体の範囲を動的に取得

Set rngTable = PasteDestination.Range("A1").CurrentRegion

' 表全体に枠線を設定

With rngTable.Borders

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlThin

End With

End Sub

コードの解説

このVBAコードは、大きく分けて５つの機能で構成されています。

メイン処理：各処理の呼び出しや基本情報の取得を行います。
品種情報取得 ：データ分別のキーとなる情報を取得します。
ワークシート作成：品種情報をもとにワークシートを作成します。
データ貼り付け：各品種のワークシートへ情報を貼り付けます。
書式貼り付け：データシートの書式を使って各品種の書式を合わせます。

メイン処理（Sample10）の特徴

コードの２５行目で「Category_Name」の値を利用してループ処理を行い、次の２６行目で後の処理をループするために変数の初期化を行っています。

Sub Sample10()
    ' グレード名、グレード、データの配列を定義
    Dim Category_Name As Variant, Category As Variant, Data_C As Variant
    Dim Category_List As Object ' グレード名を保持する辞書
    Dim wsData As Worksheet, wsCategory As Worksheet ' データシートとグレードシートの参照
    Dim LAST_R As Long, LAST_C As Long ' データ範囲の最終行と最終列

    ' データシートの参照を設定
    Set wsData = Worksheets("データシート")
    
    ' データシートの最終列行を取得
    LAST_C = wsData.Cells(2, Columns.Count).End(xlToLeft).Column
    LAST_R = wsData.Cells(Rows.Count, 2).End(xlUp).Row

    ' グレードリストを取得
    Call GetCategory(Category, Category_List, wsData, LAST_R)

    ' グレード名称を配列に変換
    Category_Name = Category_List.Keys

    ' データを配列に読み込む（2行目以降のデータ範囲）
    Data_C = wsData.Range(wsData.Cells(2, 2), wsData.Cells(LAST_R, LAST_C)).Value

    ' 各グレードごとに処理
    For Each Category In Category_Name
        Set wsCategory = Nothing   ' ワークシート参照のリセット
        
        ' グレード用のワークシートを作成または取得
        Call MakeWorkSheet(Category, wsCategory)
        
        ' データを各グレードのワークシートに貼り付け
        Call DataPaste(Category, wsCategory, LAST_C, Data_C)
    Next Category

End Sub&nbsp;

Sub Sample10()

' グレード名、グレード、データの配列を定義

Dim Category_Name As Variant, Category As Variant, Data_C As Variant

Dim Category_List As Object ' グレード名を保持する辞書

Dim wsData As Worksheet, wsCategory As Worksheet ' データシートとグレードシートの参照

Dim LAST_R As Long, LAST_C As Long ' データ範囲の最終行と最終列

' データシートの参照を設定

Set wsData = Worksheets("データシート")

' データシートの最終列行を取得

LAST_C = wsData.Cells(2, Columns.Count).End(xlToLeft).Column

LAST_R = wsData.Cells(Rows.Count, 2).End(xlUp).Row

' グレードリストを取得

Call GetCategory(Category, Category_List, wsData, LAST_R)

' グレード名称を配列に変換

Category_Name = Category_List.Keys

' データを配列に読み込む（2行目以降のデータ範囲）

Data_C = wsData.Range(wsData.Cells(2, 2), wsData.Cells(LAST_R, LAST_C)).Value

' 各グレードごとに処理

For Each Category In Category_Name

Set wsCategory = Nothing ' ワークシート参照のリセット

' グレード用のワークシートを作成または取得

Call MakeWorkSheet(Category, wsCategory)

' データを各グレードのワークシートに貼り付け

Call DataPaste(Category, wsCategory, LAST_C, Data_C)

Next Category

End Sub 

品種情報取得（GetCategory）の特徴

コードの９行目で「Scripting.Dictionary」を使用して品種名称を取得する事でリサイズが不要で重複のないカテゴリー名称を取得しています。

Sub GetCategory(ByRef Category As Variant, _
                ByRef Category_List As Object, _
                ByRef wsData As Worksheet, _
                ByVal LAST_R As Long)
    ' グレード名称リストの作成（重複を排除）
    Dim i As Long

    ' グレード名を保持する辞書を作成
    Set Category_List = CreateObject("Scripting.Dictionary")
    
    ' 各行のグレードを辞書に追加（重複を防ぐ）
    For i = 2 To LAST_R
        Category = wsData.Cells(i, 2).Value
        If Not Category_List.exists(Category) Then
            Category_List.Add Category, Nothing
        End If
    Next i
End Sub&nbsp;

Sub GetCategory(ByRef Category As Variant, _

ByRef Category_List As Object, _

ByRef wsData As Worksheet, _

ByVal LAST_R As Long)

' グレード名称リストの作成（重複を排除）

Dim i As Long

' グレード名を保持する辞書を作成

Set Category_List = CreateObject("Scripting.Dictionary")

' 各行のグレードを辞書に追加（重複を防ぐ）

For i = 2 To LAST_R

Category = wsData.Cells(i, 2).Value

If Not Category_List.exists(Category) Then

Category_List.Add Category, Nothing

End If

Next i

End Sub 

ワークシート作成（MakeWorkSheet）の特徴

コードの５～７行目で作成するワークシートの有無を確認しています。その際のエラー回避として５行目に「OnErrorResumeNext」の処理を記述しています。

Sub MakeWorkSheet(ByVal Category As Variant, _
                  ByRef wsCategory As Worksheet)
    ' グレード用のワークシートの存在確認と新規作成

    On Error Resume Next ' エラーを無視して既存のワークシートを探す
    Set wsCategory = Worksheets(Category)
    On Error GoTo 0 ' エラー処理をリセット
    
    ' ワークシートが存在しない場合は新規作成
    If wsCategory Is Nothing Then
        Set wsCategory = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wsCategory.Name = Category ' ワークシート名をグレード名に設定
    Else
        ' 既存のワークシートの場合、必要に応じて内容をクリアなどの処理を追加
    End If
    
    ' ワークシートのフォーマットを設定
    Call FormatChange(wsCategory)
End Sub

Sub MakeWorkSheet(ByVal Category As Variant, _

ByRef wsCategory As Worksheet)

' グレード用のワークシートの存在確認と新規作成

On Error Resume Next ' エラーを無視して既存のワークシートを探す

Set wsCategory = Worksheets(Category)

On Error GoTo 0 ' エラー処理をリセット

' ワークシートが存在しない場合は新規作成

If wsCategory Is Nothing Then

Set wsCategory = Worksheets.Add(After:=Worksheets(Worksheets.Count))

wsCategory.Name = Category ' ワークシート名をグレード名に設定

Else

' 既存のワークシートの場合、必要に応じて内容をクリアなどの処理を追加

End If

' ワークシートのフォーマットを設定

Call FormatChange(wsCategory)

End Sub

データ貼り付け（DataPaste）の特徴

このコードでは「RowCounter」でデータの入力行を制御しています。

Sub DataPaste(ByVal Category As Variant, _
              ByVal wsCategory As Worksheet, _
              ByVal LAST_C As Long, _
              ByVal Data_C As Variant)
    ' グレードに対応する行をフィルタリングして貼り付け
    Dim RowCounter As Long ' 貼り付け行のカウンタ
    Dim i As Long

    ' 初期貼り付け行位置
    RowCounter = 0
    
    ' 配列から該当するグレードの行をフィルタしてワークシートに貼り付け
    For i = 1 To UBound(Data_C, 1)
        If Data_C(i, 1) = Category Then
            wsCategory.Cells(RowCounter + 2, 2).Resize(1, LAST_C - 1).Value = _
                Application.Index(Data_C, i, 0) ' 該当行を貼り付け
            RowCounter = RowCounter + 1 ' 次の行に移動
        End If
    Next i
End Sub

Sub DataPaste(ByVal Category As Variant, _

ByVal wsCategory As Worksheet, _

ByVal LAST_C As Long, _

ByVal Data_C As Variant)

' グレードに対応する行をフィルタリングして貼り付け

Dim RowCounter As Long ' 貼り付け行のカウンタ

Dim i As Long

' 初期貼り付け行位置

RowCounter = 0

' 配列から該当するグレードの行をフィルタしてワークシートに貼り付け

For i = 1 To UBound(Data_C, 1)

If Data_C(i, 1) = Category Then

wsCategory.Cells(RowCounter + 2, 2).Resize(1, LAST_C - 1).Value = _

Application.Index(Data_C, i, 0) ' 該当行を貼り付け

RowCounter = RowCounter + 1 ' 次の行に移動

End If

Next i

End Sub

書式貼り付け（FormatChange）の特徴

コードの１５行目で「CurrentRegion」を使用して表全体を選択し罫線を引いています。

Sub FormatChange(ByVal PasteDestination As Worksheet)
    Dim wsSorce As Worksheet
    Dim rngTable As Range

    ' データシートの参照を取得
    Set wsSorce = Worksheets("データシート")
    
    ' データシートのA列をコピーして、各グレードシートのA列に貼り付け
    wsSorce.Columns("A:A").Copy destination:=PasteDestination.Columns("A:A")
    
    ' データシートの1行目をコピーして、各グレードシートの1行目に貼り付け
    wsSorce.Rows("1:1").Copy destination:=PasteDestination.Rows("1:1")
    
    ' シートのA1を起点として表全体の範囲を動的に取得
    Set rngTable = PasteDestination.Range("A1").CurrentRegion
    
    ' 表全体に枠線を設定
    With rngTable.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

Sub FormatChange(ByVal PasteDestination As Worksheet)

Dim wsSorce As Worksheet

Dim rngTable As Range

' データシートの参照を取得

Set wsSorce = Worksheets("データシート")

' データシートのA列をコピーして、各グレードシートのA列に貼り付け

wsSorce.Columns("A:A").Copy destination:=PasteDestination.Columns("A:A")

' データシートの1行目をコピーして、各グレードシートの1行目に貼り付け

wsSorce.Rows("1:1").Copy destination:=PasteDestination.Rows("1:1")

' シートのA1を起点として表全体の範囲を動的に取得

Set rngTable = PasteDestination.Range("A1").CurrentRegion

' 表全体に枠線を設定

With rngTable.Borders

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlThin

End With

End Sub

変数とパラメータの詳細説明

Category_List: Scripting.Dictionaryオブジェクトを使用して品種名を取得している。
Category_Name: Category_Listから品種名のリストを格納し、含まれる品種名称を示す。
LAST_R / LAST_C: データシートの最終行と最終列を示し、データ範囲の動的な取得に使用。
wsCategory: 各品種用のワークシートを指す変数。
RowCounter: データを各ワークシートに貼り付ける際に貼り付ける行番号の制御に使用。
rngTable: 書式設定を行う範囲を示す変数。表全体の範囲を動的に取得し、書式設定を適用。

使用している技術

基本：For – Next、二次元配列、Column、Row、Scripting.Dictionary、Application.Index、On Error、Worksheets.Add、Borders、引数、CurrentRegion

まとめ

この記事では、Excel VBAを使ってデータを品種やカテゴリごとに自動で各シートへ転記する方法を紹介しました。VBAコードを活用することで、データの読み込みからシート作成、データの貼り付け、書式の統一までの一連の作業が自動化され、手動操作によるミスも防げます。特に、Scripting.Dictionaryを用いた品種情報の取得や、ワークシートの自動生成などのポイントが効率化に役立ちます。Excelでのデータ整理をもっとスマートにしたい方は、ぜひVBAを活用してみてください。