MENU
  1. ホーム
  2. VBA
  3. VBAを用いたデータ集計

VBAを用いたデータ集計

VBA

はじめに

このプロジェクトでは、VBAを活用して補正後のデータを用いてピボットテーブルを作成するプログラムを作成しました。以下に、各コードの機能とその動作について詳細な解説を行います。

目次

merged_data シートのデータを元にピボットテーブルを作成

ソースコード

Sub CreatePivotTable(indexField As String, columnField As String, aggField As String, aggFunc As XlConsolidationFunction, clearSheet As Boolean)
    Dim wsSource As Worksheet
    Dim wsPivot As Worksheet
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim lastRow As Long
    Dim dataRange As Range
    Dim pivotStartRow As Long
    Dim newTableName As String
    Dim dataTitle As String
    Dim i As Long
    Dim fieldExists As Boolean
    
    ' 画面更新を停止（パフォーマンス向上）
    Application.ScreenUpdating = False
    
    ' ソースシート（merged_data）を指定
    On Error Resume Next
    Set wsSource = Sheets("merged_data")
    If wsSource Is Nothing Then
        MsgBox "ソースシート 'merged_data' が見つかりません。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 最終行を取得（A列基準）
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    
    ' データ範囲を取得（A列～I列）
    If lastRow < 2 Then
        MsgBox "データが不足しています。", vbExclamation
        Exit Sub
    End If
    Set dataRange = wsSource.Range("A1:I" & lastRow)
    
    ' ピボットテーブル用のシートを取得または作成
    On Error Resume Next
    Set wsPivot = Sheets("Aggregated_Data")
    On Error GoTo 0
    If wsPivot Is Nothing Then
        Set wsPivot = Sheets.Add(After:=Sheets(Sheets.Count))
        wsPivot.Name = "Aggregated_Data"
    End If
    
    ' シートをクリアする場合
    If clearSheet Then
        wsPivot.Cells.Clear
    End If
    
    ' ピボット出力開始位置を最終行の2行下に設定（空ならA1セル）
    pivotStartRow = wsPivot.Cells(wsPivot.Rows.Count, 1).End(xlUp).Row
    If pivotStartRow < 2 Then
        pivotStartRow = 1
    Else
        pivotStartRow = pivotStartRow + 2
    End If
    
    ' --- フィールド名の存在確認 ---
    fieldExists = False
    For Each cell In wsSource.Rows(1).Cells
        If cell.value = indexField Or cell.value = columnField Or cell.value = aggField Then
            fieldExists = True
            Exit For
        End If
    Next cell
    
    If Not fieldExists Then
        MsgBox "指定されたフィールドが見つかりません。フィールド名を確認してください。", vbCritical
        Exit Sub
    End If
    
    ' --- 重複しないピボットテーブル名を作成 ---
    i = 1
    Do While i <= 1000
        newTableName = "PivotTableFromMergedData_" & i
        On Error Resume Next
        Set pt = Nothing
        Set pt = wsPivot.PivotTables(newTableName)
        On Error GoTo 0
        If pt Is Nothing Then Exit Do
        i = i + 1
    Loop
    
    If i > 1000 Then
        MsgBox "ピボットテーブル作成回数が1000回を超えました。処理を終了します。", vbCritical
        Exit Sub
    End If
    
    ' --- データタイトルを自動生成 ---
    dataTitle = "[" & indexField & "]_[" & columnField & "]"
    
    ' --- ピボットキャッシュを作成 ---
    Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
    
    ' --- ピボットテーブルを作成 ---
    Set pt = pc.CreatePivotTable(TableDestination:=wsPivot.Cells(pivotStartRow, 1), TableName:=newTableName)
    
    ' --- ピボットテーブルのフィールド設定 ---
    With pt
        ' indexFieldを行フィールドに設定
        With .PivotFields(indexField)
            .Orientation = xlRowField
            .Position = 1
        End With
        
        ' columnFieldを列フィールドに設定
        With .PivotFields(columnField)
            .Orientation = xlColumnField
            .Position = 1
        End With
        
        ' データフィールドを指定された関数で追加（自動生成タイトル）
        .AddDataField .PivotFields(aggField), dataTitle, aggFunc
        
        ' 空白セルに 0 を表示
        .NullString = "0"
        
        ' 総計を表示
        .RowGrand = True
        .ColumnGrand = True
        
        ' 見た目の調整
        .ShowTableStyleRowStripes = True
        .InGridDropZones = True
        .DisplayFieldCaptions = False
    End With
    
    ' 列幅を自動調整
    wsPivot.Cells.EntireColumn.AutoFit
    
    ' 画面更新を再開
    Application.ScreenUpdating = True
    
    MsgBox "ピボットテーブル '" & newTableName & "' が作成されました。タイトル: '" & dataTitle & "'", vbInformation
End Sub

処理の概要

  1. merged_data シートを取得。
  2. データ範囲を特定（A列〜I列）。
  3. ピボットテーブルの出力シートを Aggregated_Data に設定。
  4. 指定したフィールドをもとにピボットテーブルを作成。
  5. 列幅を自動調整。
  6. 処理完了メッセージを表示。

対象のシートを指定

まず、ピボットテーブルの元データがある merged_data シートを取得します。

Dim wsSource As Worksheet
Set wsSource = Sheets("merged_data")
  • Dim wsSource As Worksheet で wsSource という変数を作成し、ワークシートのオブジェクトを格納。
  • Set wsSource = Sheets("merged_data") で merged_data シートを取得。

データ範囲を特定

A列を基準にデータの最終行を取得し、データ範囲を指定します。

lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
Set dataRange = wsSource.Range("A1:I" & lastRow)
  • wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row でA列の最終行を取得。
  • Range("A1:I" & lastRow) でA列からI列までのデータ範囲を設定。

ピボットテーブルの作成

指定したフィールドでピボットテーブルを作成します。

Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
Set pt = pc.CreatePivotTable(TableDestination:=wsPivot.Cells(pivotStartRow, 1), TableName:=newTableName)
  • PivotCaches.Create でピボットキャッシュを作成。
  • CreatePivotTable で Aggregated_Data シートにピボットテーブルを作成。

フィールド設定

ピボットテーブルの行・列・集計フィールドを設定します。

With pt
    ' 行フィールドを設定
    With .PivotFields(indexField)
        .Orientation = xlRowField
        .Position = 1
    End With
    
    ' 列フィールドを設定
    With .PivotFields(columnField)
        .Orientation = xlColumnField
        .Position = 1
    End With
    
    ' 集計フィールドを追加
    .AddDataField .PivotFields(aggField), dataTitle, aggFunc
    
    ' 空白セルに0を表示
    .NullString = "0"
    
    ' 総計を表示
    .RowGrand = True
    .ColumnGrand = True
    
    ' 見た目の調整
    .ShowTableStyleRowStripes = True
    .InGridDropZones = True
    .DisplayFieldCaptions = False
End With
  • .PivotFields(indexField).Orientation = xlRowField で行フィールドを設定。
  • .PivotFields(columnField).Orientation = xlColumnField で列フィールドを設定。
  • .AddDataField .PivotFields(aggField), dataTitle, aggFunc で集計方法を指定。
  • .NullString = "0" で空白セルに 0 を設定。
  • .RowGrand = True で行合計を表示。
  • .ColumnGrand = True で列合計を表示。
  • .AutoFit で列幅を調整。

処理完了メッセージの表示

処理が完了したことをユーザーに通知します。

MsgBox "ピボットテーブル '" & newTableName & "' が作成されました。タイトル: '" & dataTitle & "'", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

CreatePivotTable を使用して複数のピボットテーブルを作成

ソースコード

Sub RunPivotTable()
    ' シートをクリアして新たに作成する
    Call CreatePivotTable("purchase_month", "item_name", "purchase_date", xlCount, True)
    
    ' 既存データを保持しつつ、次のピボットテーブルを作成する
    Call CreatePivotTable("purchase_month", "item_name", "item_price", xlSum, False)
    
    ' さらに追加で作成する場合
    Call CreatePivotTable("purchase_month", "customer_name", "purchase_date", xlCount, False)
    
    Call CreatePivotTable("purchase_month", "地域", "purchase_date", xlCount, False)
End Sub

処理の概要

このマクロは以下の流れで処理を行います。

  1. CreatePivotTable() を呼び出し、ピボットシートをクリアして新たなピボットテーブルを作成。
  2. 既存のピボットデータを保持しながら、異なる集計軸でピボットテーブルを追加。
  3. purchase_month（購入月）を基準に、item_name（商品名）、customer_name（顧客名）、地域（エリア）ごとのデータを集計。

各ピボットテーブルの設定

  1. 購入月 × 商品名 × 購入数（カウント）Call CreatePivotTable("purchase_month", "item_name", "purchase_date", xlCount, True)
    • purchase_month（購入月）ごとに item_name（商品名）を集計。
    • purchase_date（購入日）のカウント（購入数）を集計。
    • True を指定し、ピボットテーブルを新しく作成（シートをクリア）。
  2. 購入月 × 商品名 × 売上合計Call CreatePivotTable("purchase_month", "item_name", "item_price", xlSum, False)
    • purchase_month（購入月）ごとに item_name（商品名）を集計。
    • item_price（商品価格）の合計（売上）を計算。
    • False を指定し、既存データを保持したまま追加。
  3. 購入月 × 顧客名 × 購入数（カウント）Call CreatePivotTable("purchase_month", "customer_name", "purchase_date", xlCount, False)
    • purchase_month（購入月）ごとに customer_name（顧客名）を集計。
    • purchase_date（購入日）のカウント（購入回数）を集計。
    • False を指定し、既存データを保持したまま追加。
  4. 購入月 × 地域 × 購入数（カウント）Call CreatePivotTable("purchase_month", "地域", "purchase_date", xlCount, False)
    • purchase_month（購入月）ごとに 地域（エリア）を集計。
    • purchase_date（購入日）のカウント（購入数）を集計。
    • False を指定し、既存データを保持したまま追加。

購入履歴のない顧客リストを抽出

ソースコード

Sub ExtractNoPurchaseRecords()
    Dim wsUriage As Worksheet
    Dim wsCustomer As Worksheet
    Dim wsOutput As Worksheet
    
    Dim lastRowUriage As Long
    Dim lastRowCustomer As Long
    Dim uriageDict As Object
    
    Dim cell As Range
    Dim outputRow As Long
    
    ' 画面更新を停止（パフォーマンス向上）
    Application.ScreenUpdating = False
    
    ' シートの設定
    Set wsUriage = Sheets("uriage")
    Set wsCustomer = Sheets("kokyaku_daicho_Sheet1")
    
    ' NoPurchaseRecordsシートを追加（既に存在する場合は削除して再作成）
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("NoPurchaseRecords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Set wsOutput = Sheets.Add(After:=Sheets(Sheets.Count))
    wsOutput.Name = "NoPurchaseRecords"
    
    ' ユニーク値管理用の辞書を作成
    Set uriageDict = CreateObject("Scripting.Dictionary")
    
    ' uriageシートのD列からユニークな値を取得
    lastRowUriage = wsUriage.Cells(wsUriage.Rows.Count, 4).End(xlUp).Row
    If lastRowUriage >= 2 Then
        For Each cell In wsUriage.Range("D2:D" & lastRowUriage)
            If Not IsEmpty(cell.value) Then
                uriageDict(cell.value) = True
            End If
        Next cell
    End If
    
    ' kokyaku_daicho_Sheet1のA列を確認し、D列にない行を出力
    lastRowCustomer = wsCustomer.Cells(wsCustomer.Rows.Count, 1).End(xlUp).Row
    If lastRowCustomer < 2 Then
        MsgBox "kokyaku_daicho_Sheet1のA列にデータがありません。", vbExclamation
        Exit Sub
    End If
    
    ' ヘッダー行をコピー
    wsCustomer.Rows(1).Copy Destination:=wsOutput.Rows(1)
    
    ' データ行の出力開始行を2行目に設定
    outputRow = 2
    
    ' A列をキーにしてD列を検索し、見つからない行をコピー
    For Each cell In wsCustomer.Range("A2:A" & lastRowCustomer)
        If Not IsEmpty(cell.value) Then
            If Not uriageDict.exists(cell.value) Then
                ' 該当行を出力先にコピー
                cell.EntireRow.Copy Destination:=wsOutput.Rows(outputRow)
                outputRow = outputRow + 1
            End If
        End If
    Next cell
    
    ' 列幅を自動調整（オートフィット）
    wsOutput.Columns.AutoFit
    
    ' 結果のメッセージ表示
    If outputRow = 2 Then
        MsgBox "A列に存在し、D列に存在しないデータはありませんでした。", vbInformation
    Else
        MsgBox "A列に存在し、D列に存在しないデータが " & (outputRow - 2) & " 件出力されました。", vbInformation
    End If
    
    ' 画面更新を再開
    Application.ScreenUpdating = True
End Sub

処理の概要

このマクロは以下の流れで処理を行います。

  1. uriage シートのD列（顧客ID）から、購入履歴のある顧客を取得。
  2. kokyaku_daicho_Sheet1 シートのA列（顧客ID）を確認し、D列 に存在しない顧客を抽出。
  3. NoPurchaseRecords シートを作成し、購入履歴のない顧客データを出力。
  4. 列幅を自動調整。
  5. 処理完了メッセージを表示。

対象のシートを指定

まず、売上データのある uriage シートと、顧客データのある kokyaku_daicho_Sheet1 シートを取得します。

Dim wsUriage As Worksheet
Dim wsCustomer As Worksheet
Set wsUriage = Sheets("uriage")
Set wsCustomer = Sheets("kokyaku_daicho_Sheet1")
  • Dim wsUriage As Worksheet で uriage シートを取得。
  • Dim wsCustomer As Worksheet で kokyaku_daicho_Sheet1 シートを取得。

売上データの顧客IDを辞書に登録

uriage シートの D列（顧客ID）を辞書に登録し、購入履歴のある顧客を管理します。

Set uriageDict = CreateObject("Scripting.Dictionary")
For Each cell In wsUriage.Range("D2:D" & lastRowUriage)
    If Not IsEmpty(cell.value) Then
        uriageDict(cell.value) = True
    End If
Next cell
  • CreateObject("Scripting.Dictionary") で辞書オブジェクトを作成。
  • D列（顧客ID）をキーとして辞書に格納。
  • Not IsEmpty(cell.value) で空白セルを除外。

購入履歴のない顧客を抽出

顧客台帳 kokyaku_daicho_Sheet1 の A列（顧客ID）を D列（売上データ）と比較し、該当しない顧客を NoPurchaseRecords シートに出力します。

For Each cell In wsCustomer.Range("A2:A" & lastRowCustomer)
    If Not IsEmpty(cell.value) Then
        If Not uriageDict.exists(cell.value) Then
            cell.EntireRow.Copy Destination:=wsOutput.Rows(outputRow)
            outputRow = outputRow + 1
        End If
    End If
Next cell
  • A列（顧客ID）をループ処理。
  • Not uriageDict.exists(cell.value) により D列 に存在しないデータを抽出。
  • cell.EntireRow.Copy で該当行を NoPurchaseRecords シートにコピー。

列幅の自動調整

データの視認性を向上させるため、列幅を自動調整します。

wsOutput.Columns.AutoFit
  • .AutoFit により、データに応じた適切な列幅を設定。

処理完了メッセージの表示

処理が完了したことをユーザーに通知します。

If outputRow = 2 Then
    MsgBox "A列に存在し、D列に存在しないデータはありませんでした。", vbInformation
Else
    MsgBox "A列に存在し、D列に存在しないデータが " & (outputRow - 2) & " 件出力されました。", vbInformation
End If
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。
  • outputRow = 2 の場合、該当データがないことを通知。
  • それ以外の場合、抽出件数を表示。

これで、データ整理の一連の流れは終了です。

VBA
よかったらシェアしてね！
  • URLをコピーしました！
  • URLをコピーしました！

この記事を書いた人

Katsumaのアバター Katsuma

関連記事

コメント

コメントする

目次