MENU
  1. ホーム
  2. VBA
  3. VBAを用いたデータ補正

VBAを用いたデータ補正

VBA

はじめに

本プロジェクトでは、Excel VBAを活用して、データのフォーマット、ユニークデータのカウント、文字列の整形、価格データの作成と転記、シート間のマージ処理をするプログラムを作成しました。以下に、各コードの機能とその動作について詳細な解説を行います。

目次

uriageシートの日付フォーマットゆれを補正

ソースコード

Sub FormatColumnA()
    Dim ws As Worksheet
    Set ws = Worksheets("uriage")

    With ws.Range("A2:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
        .NumberFormat = "yyyy/mm/dd hh:mm"
    End With

    MsgBox "uriageシートのA列の2行目以降を yyyy/mm/dd hh:mm フォーマットに変更しました。", vbInformation
End Sub

処理の概要

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

  1. uriage シートを取得。
  2. A列の最終行を取得し、データ範囲を特定。
  3. 日付フォーマット (yyyy/mm/dd hh:mm) を適用。
  4. 処理完了メッセージを表示。

対象のシートを指定

まず、フォーマット変更を行うシート uriage を指定します。

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

A列のデータ範囲を取得し、フォーマットを適用

A列の2行目以降のデータを対象に、日付フォーマットを適用します。

With ws.Range("A2:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
    .NumberFormat = "yyyy/mm/dd hh:mm"
End With
  • ws.Cells(ws.Rows.Count, 1).End(xlUp).Row でA列の最終行を取得。
  • Range("A2:A" & 最終行) でA列の2行目から最終行までの範囲を選択。
  • .NumberFormat = "yyyy/mm/dd hh:mm" で指定のフォーマットを適用。

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

フォーマット変更が完了したことをユーザーに知らせます。

MsgBox "uriageシートのA列の2行目以降を yyyy/mm/dd hh:mm フォーマットに変更しました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

Before

After

kokyaku_daicho_Sheet1シートの日付フォーマットゆれを補正

ソースコード

Sub FormatDateInColumnE()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim targetSheetName As String
    Dim targetColumn As String

    targetSheetName = "kokyaku_daicho_Sheet1"
    targetColumn = "E"

    Set ws = Sheets(targetSheetName)
    lastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row

    If lastRow >= 2 Then
        With ws.Range(targetColumn & "2:" & targetColumn & lastRow)
            .NumberFormat = "yyyy/mm/dd"
            .Font.Name = "游ゴシック"
            .HorizontalAlignment = xlRight
            .Columns.AutoFit
        End With
        MsgBox "E列のフォーマットが完了しました。", vbInformation
    Else
        MsgBox "E列にデータがありません。", vbExclamation
    End If
End Sub

処理の概要

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

  1. 指定したシート（kokyaku_daicho_Sheet1）を取得。
  2. E列の最終行を取得し、データ範囲を特定。
  3. 日付フォーマット (yyyy/mm/dd) を適用。
  4. フォント (游ゴシック) を設定。
  5. 右揃え (xlRight) に設定。
  6. 列幅を自動調整 (AutoFit)。
  7. 処理完了メッセージを表示。

対象のシートを指定

まず、フォーマット変更を行うシート kokyaku_daicho_Sheet1 を指定します。

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

E列のデータ範囲を取得し、フォーマットを適用

E列の2行目以降のデータを対象に、日付フォーマットを適用します。

lastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row
With ws.Range("E2:E" & lastRow)
    .NumberFormat = "yyyy/mm/dd"
    .Font.Name = "游ゴシック"
    .HorizontalAlignment = xlRight
    .Columns.AutoFit
End With
  • ws.Cells(ws.Rows.Count, 5).End(xlUp).Row でE列の最終行を取得。
  • Range("E2:E" & 最終行) でE列の2行目から最終行までの範囲を選択。
  • .NumberFormat = "yyyy/mm/dd" で日付フォーマットを適用。
  • .Font.Name = "游ゴシック" でフォントを統一。
  • .HorizontalAlignment = xlRight で右揃えに設定。
  • .Columns.AutoFit で列幅を自動調整。

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

フォーマット変更が完了したことをユーザーに知らせます。

MsgBox "E列のフォーマットが完了しました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

顧客名の表記ゆれの補正

ソースコード

Sub ConvertToUpperAndRemoveSpaces(targetSheetName As String, targetColumn As String)
    Dim ws As Worksheet
    Dim cell As Range
    Dim lastRow As Long

    Set ws = Sheets(targetSheetName)
    lastRow = ws.Cells(ws.Rows.Count, Columns(targetColumn).Column).End(xlUp).Row

    For Each cell In ws.Range(targetColumn & "2:" & targetColumn & lastRow)
        If Not IsEmpty(cell.Value) Then
            cell.Value = RemoveSpaces(UCase(cell.Value))
        End If
    Next cell

    ws.Columns(targetColumn).AutoFit
    MsgBox targetSheetName & "の" & targetColumn & "列を整形しました。", vbInformation
End Sub

Private Function RemoveSpaces(str As String) As String
    RemoveSpaces = Replace(Replace(str, " ", ""), "　", "")
End Function

Sub run_uriage_B()
    Call ConvertToUpperAndRemoveSpaces("uriage", "B")
End Sub

Sub run_kokyaku_daicho_A_B()
    Call ConvertToUpperAndRemoveSpaces("kokyaku_daicho_Sheet1", "A")
    Call ConvertToUpperAndRemoveSpaces("kokyaku_daicho_Sheet1", "B")
End Sub

処理の概要

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

  1. 指定したシートと列のデータ範囲を取得。
  2. 各セルの値を大文字に変換。
  3. 半角・全角の空白を削除。
  4. 列幅を自動調整。
  5. 処理完了メッセージを表示。

対象のシートを指定

まず、処理を行う対象のシートを指定します。

Dim ws As Worksheet
Set ws = Sheets(targetSheetName)
  • Dim ws As Worksheet で ws という変数を作成し、ワークシートのオブジェクトを格納。
  • Set ws = Sheets(targetSheetName) で targetSheetName に指定したシートを取得。

対象列のデータ範囲を取得し、変換を適用

指定した列の2行目以降のデータを対象に、文字列の変換を適用します。

lastRow = ws.Cells(ws.Rows.Count, Columns(targetColumn).Column).End(xlUp).Row
For Each cell In ws.Range(targetColumn & "2:" & targetColumn & lastRow)
    If Not IsEmpty(cell.Value) Then
        cell.Value = RemoveSpaces(UCase(cell.Value))
    End If
Next cell
  • ws.Cells(ws.Rows.Count, Columns(targetColumn).Column).End(xlUp).Row で指定列の最終行を取得。
  • Range(targetColumn & "2:" & targetColumn & lastRow) で指定列の2行目から最終行までの範囲を選択。
  • UCase(cell.Value) で大文字に変換。
  • RemoveSpaces(cell.Value) で半角・全角スペースを削除。

空白削除の関数

Private Function RemoveSpaces(str As String) As String
    RemoveSpaces = Replace(Replace(str, " ", ""), "　", "")
End Function
  • Replace(str, " ", "") で半角スペースを削除。
  • Replace(str, "　", "") で全角スペースを削除。

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

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

MsgBox targetSheetName & "の" & targetColumn & "列を整形しました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

Sub run_uriage_B()

uriage シートの B 列を対象に、大文字変換と空白削除を実行します。

Before

After

Sub run_kokyaku_daicho_A_B()

kokyaku_daicho_Sheet1 シートの A 列と B 列を対象に、大文字変換と空白削除を実行します。

Before

After

ユニークなアイテム価格表の作成

ソースコード

Sub CreateUniqueItemPriceTable()
    Const sheet_name As String = "Item_Price"
    Const SOURCE_SHEET As String = "uriage"
    
    Dim ws As Worksheet
    Dim newSheet As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim uniqueDict As Object
    Dim itemName As Variant
    Dim itemPrice As Variant
    
    ' uriageシートを指定
    On Error Resume Next
    Set ws = Sheets(SOURCE_SHEET)
    If ws Is Nothing Then
        MsgBox "シート '" & SOURCE_SHEET & "' が見つかりません。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' B列の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
    
    ' ユニークな対応表を保持するディクショナリ作成
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' B列とC列をループしてデータを収集
    For Each cell In ws.Range("B2:B" & lastRow)
        itemName = cell.Value
        itemPrice = cell.Offset(0, 1).Value ' C列の値を取得
        
        ' C列が空でないかを確認し、ユニークなアイテム名に対してのみ価格を登録
        If Not IsEmpty(itemName) And Not IsEmpty(itemPrice) Then
            If Not uniqueDict.exists(itemName) Then
                uniqueDict.Add itemName, itemPrice
            End If
        End If
    Next cell
    
    ' 既に存在するシートを削除（エラー回避）
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets(sheet_name).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    ' 新しいシートを作成
    Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    newSheet.Name = sheet_name
    
    ' カラム名を設定
    newSheet.Cells(1, 1).Value = "item_name"
    newSheet.Cells(1, 2).Value = "item_price"
    
    ' ユニークな対応表を出力
    Dim i As Long
    i = 2
    For Each itemName In uniqueDict.keys
        newSheet.Cells(i, 1).Value = itemName
        newSheet.Cells(i, 2).Value = uniqueDict(itemName)
        i = i + 1
    Next itemName
    
    ' 列幅の自動調整
    newSheet.Columns("A:B").AutoFit
    
    ' ソート処理：item_name列を昇順でソート
    lastRow = newSheet.Cells(newSheet.Rows.Count, 1).End(xlUp).Row
    With newSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=newSheet.Range("A2:A" & lastRow), Order:=xlAscending
        .SetRange newSheet.Range("A1:B" & lastRow)
        .Header = xlYes
        .Apply
    End With
    
    MsgBox "ユニークな対応表を '" & sheet_name & "' シートに作成し、item_nameでソートしました。", vbInformation
End Sub

処理の概要

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

  1. uriage シートのB列（商品名）とC列（価格）のデータを取得。
  2. Scripting.Dictionary を使用し、ユニークな商品名とその価格を抽出。
  3. Item_Price シートを作成し、ユニークなデータを出力。
  4. 商品名（item_name）で昇順ソート。
  5. ユーザーに処理完了のメッセージを表示。

対象のシートを指定

まず、処理を行う対象のシート uriage を指定します。

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

商品データの取得と辞書への登録

商品名と価格を Scripting.Dictionary を用いてユニークに整理します。

Set uniqueDict = CreateObject("Scripting.Dictionary")
For Each cell In ws.Range("B2:B" & lastRow)
    itemName = cell.Value
    itemPrice = cell.Offset(0, 1).Value ' C列の値を取得
    
    If Not IsEmpty(itemName) And Not IsEmpty(itemPrice) Then
        If Not uniqueDict.exists(itemName) Then
            uniqueDict.Add itemName, itemPrice
        End If
    End If
Next cell
  • Scripting.Dictionary を利用し、商品名をキー、価格を値として格納。
  • 重複を避けるため、If Not uniqueDict.exists(itemName) で登録前にチェック。
  • 空白セルを排除するため、Not IsEmpty(itemName) And Not IsEmpty(itemPrice) で確認。

新しいシートを作成し、データを出力

ユニークな商品リストを Item_Price シートに書き出します。

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Item_Price"
With Sheets("Item_Price")
    .Cells(1, 1).Value = "item_name"
    .Cells(1, 2).Value = "item_price"
    
    Dim i As Long: i = 2
    For Each itemName In uniqueDict.keys
        .Cells(i, 1).Value = itemName
        .Cells(i, 2).Value = uniqueDict(itemName)
        i = i + 1
    Next itemName
    
    .Columns("A:B").AutoFit
End With
  • Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Item_Price" で新しいシートを作成。
  • Cells(1,1).Value でヘッダーを設定。
  • 辞書のキーと値をループで書き出し、AutoFit により列幅を自動調整。

ソート処理の適用

作成した商品リストを商品名（A列）で昇順に並び替えます。

lastRow = Sheets("Item_Price").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Item_Price").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Sheets("Item_Price").Range("A2:A" & lastRow), Order:=xlAscending
    .SetRange Sheets("Item_Price").Range("A1:B" & lastRow)
    .Header = xlYes
    .Apply
End With
  • .SortFields.Add でA列を昇順に並び替え。
  • .Header = xlYes によりヘッダーを保持したまま並び替えを適用。

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

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

MsgBox "ユニークな対応表を 'Item_Price' シートに作成し、item_nameでソートしました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

uriage シートの欠損値を補正

ソースコード

Sub FillPricesFromItemPriceSheet()
    Const PRICE_SHEET As String = "Item_price"
    Const SOURCE_SHEET As String = "uriage"
    
    Dim wsSource As Worksheet
    Dim wsPrice As Worksheet
    Dim lastRowSource As Long
    Dim lastRowPrice As Long
    Dim cell As Range
    Dim priceDict As Object
    Dim itemName As Variant
    
    ' シートの取得
    On Error Resume Next
    Set wsSource = Sheets(SOURCE_SHEET)
    Set wsPrice = Sheets(PRICE_SHEET)
    If wsSource Is Nothing Or wsPrice Is Nothing Then
        MsgBox "必要なシートが見つかりません。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' uriageシートの最終行を取得
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, 2).End(xlUp).Row
    
    ' Item_priceシートの最終行を取得
    lastRowPrice = wsPrice.Cells(wsPrice.Rows.Count, 1).End(xlUp).Row
    
    ' item_nameとitem_priceの対応表をディクショナリに格納
    Set priceDict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = 2 To lastRowPrice
        itemName = wsPrice.Cells(i, 1).Value
        If Not IsEmpty(itemName) And Not priceDict.exists(itemName) Then
            priceDict.Add itemName, wsPrice.Cells(i, 2).Value
        End If
    Next i
    
    ' uriageシートのB列をループして、対応する価格をC列に入力
    For Each cell In wsSource.Range("B2:B" & lastRowSource)
        itemName = cell.Value
        If priceDict.exists(itemName) Then
            cell.Offset(0, 1).Value = priceDict(itemName)
        Else
            cell.Offset(0, 1).Value = ""
        End If
    Next cell
    
    ' 列幅自動調整（C列）
    wsSource.Columns("C").AutoFit
    
    MsgBox "uriageシートの価格を更新しました。", vbInformation
End Sub

処理の概要

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

  1. Item_Price シート（価格データ）と uriage シート（売上データ）を取得。
  2. Item_Price シートのデータを Scripting.Dictionary に格納。
  3. uriage シートのB列（商品名）をループし、対応する価格をC列に入力。
  4. C列の列幅を自動調整。
  5. 処理完了メッセージを表示。

対象のシートを指定

まず、処理を行う Item_Price シートと uriage シートを取得します。

Dim wsSource As Worksheet
Dim wsPrice As Worksheet
Set wsSource = Sheets("uriage")
Set wsPrice = Sheets("Item_Price")
  • Dim wsSource As Worksheet で uriage シートを取得。
  • Dim wsPrice As Worksheet で Item_Price シートを取得。
  • シートが存在しない場合は MsgBox で警告を出し、処理を中断。

価格データを辞書に格納

Item_Price シートの item_name と item_price の対応表を辞書 (Scripting.Dictionary) に登録します。

Set priceDict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRowPrice
    itemName = wsPrice.Cells(i, 1).Value
    If Not IsEmpty(itemName) And Not priceDict.exists(itemName) Then
        priceDict.Add itemName, wsPrice.Cells(i, 2).Value
    End If
Next i
  • CreateObject("Scripting.Dictionary") で辞書オブジェクトを作成。
  • Item_Price シートのデータを item_name をキー、item_price を値として辞書に格納。
  • Not IsEmpty(itemName) により空白セルを除外。

価格データを uriage シートに反映

辞書を利用し、uriage シートのB列（商品名）に対応する価格をC列に入力します。

For Each cell In wsSource.Range("B2:B" & lastRowSource)
    itemName = cell.Value
    If priceDict.exists(itemName) Then
        cell.Offset(0, 1).Value = priceDict(itemName)
    Else
        cell.Offset(0, 1).Value = ""
    End If
Next cell
  • For Each cell で uriage シートのB列をループ。
  • priceDict.exists(itemName) により、該当商品名の価格がある場合のみC列に入力。
  • 存在しない場合は ""（空白）を入力。

列幅の自動調整

C列のデータが見やすいように列幅を自動調整します。

wsSource.Columns("C").AutoFit
  • .AutoFit により、C列の列幅を適切に調整。

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

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

MsgBox "uriageシートの価格を更新しました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

uriage シートと kokyaku_daicho_Sheet1 のデータ結合

ソースコード

Sub MergeSheetsLeftJoinWithPurchaseMonthSafe()
    Const SOURCE_SHEET As String = "uriage"
    Const TARGET_SHEET As String = "kokyaku_daicho_Sheet1"
    Const RESULT_SHEET As String = "merged_data"
    Const SOURCE_KEY_COLUMN As String = "D"
    Const TARGET_KEY_COLUMN As String = "A"
    
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim wsResult As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim sourceDict As Object
    Dim cell As Range
    Dim keyValue As Variant
    Dim sourceRow As Long
    Dim outputRow As Long
    Dim colIndex As Integer
    Dim dataArr As Variant
    Dim dateValue As Variant
    Dim purchaseMonth As String
    
    ' パフォーマンス最適化
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' シート取得
    On Error Resume Next
    Set wsSource = Sheets(SOURCE_SHEET)
    Set wsTarget = Sheets(TARGET_SHEET)
    If wsSource Is Nothing Or wsTarget Is Nothing Then
        MsgBox "指定されたシートが見つかりません。", vbCritical
        GoTo Cleanup
    End If
    On Error GoTo 0
    
    ' 既存のmerged_dataシートを削除
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets(RESULT_SHEET).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    ' 新しいmerged_dataシートを作成
    Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count))
    wsResult.Name = RESULT_SHEET
    
    ' kokyaku_daicho_Sheet1のデータを辞書に格納（キー：A列、値：B～E列の配列）
    Set sourceDict = CreateObject("Scripting.Dictionary")
    
    ' 安全な範囲取得
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, TARGET_KEY_COLUMN).End(xlUp).Row
    
    ' 範囲が有効か確認してループ
    If lastRowTarget >= 2 Then
        For Each cell In wsTarget.Range(TARGET_KEY_COLUMN & "2:" & TARGET_KEY_COLUMN & lastRowTarget)
            keyValue = cell.Value
            If Not IsEmpty(keyValue) And Not sourceDict.exists(keyValue) Then
                dataArr = wsTarget.Cells(cell.Row, 2).Resize(1, 4).Value
                sourceDict(keyValue) = dataArr
            End If
        Next cell
    Else
        MsgBox "kokyaku_daicho_Sheet1 に有効なデータがありません。", vbExclamation
    End If
    
    ' ヘッダー行を作成
    wsResult.Cells(1, 1).Value = wsSource.Cells(1, 1).Value ' 日付列
    wsResult.Cells(1, 2).Value = "purchase_month"
    wsResult.Cells(1, 3).Value = wsSource.Cells(1, 2).Value ' item_name
    wsResult.Cells(1, 4).Value = wsSource.Cells(1, 3).Value
    wsResult.Cells(1, 5).Value = wsSource.Cells(1, 4).Value
    
    ' kokyaku_daicho_Sheet1 のヘッダー（B～E列）
    For colIndex = 2 To 5
        wsResult.Cells(1, colIndex + 4).Value = wsTarget.Cells(1, colIndex).Value
    Next colIndex
    
    ' uriageシートを基準にデータを出力（left join）
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, SOURCE_KEY_COLUMN).End(xlUp).Row
    outputRow = 2
    
    For sourceRow = 2 To lastRowSource
        keyValue = wsSource.Cells(sourceRow, SOURCE_KEY_COLUMN).Value
        
        ' 左側データ（uriageシート）の出力
        wsResult.Cells(outputRow, 1).Value = wsSource.Cells(sourceRow, 1).Value
        
        ' purchase_month列の挿入
        dateValue = wsSource.Cells(sourceRow, 1).Value
        If IsDate(dateValue) Then
            purchaseMonth = Year(dateValue) & Right("0" & Month(dateValue), 2)
        Else
            purchaseMonth = ""
        End If
        wsResult.Cells(outputRow, 2).Value = purchaseMonth
        
        ' 残りの列を転記
        wsResult.Cells(outputRow, 3).Value = wsSource.Cells(sourceRow, 2).Value
        wsResult.Cells(outputRow, 4).Value = wsSource.Cells(sourceRow, 3).Value
        wsResult.Cells(outputRow, 5).Value = wsSource.Cells(sourceRow, 4).Value
        
        ' 右側データの出力
        If sourceDict.exists(keyValue) Then
            dataArr = sourceDict(keyValue)
            wsResult.Cells(outputRow, 6).Resize(1, 4).Value = dataArr
        End If
        
        outputRow = outputRow + 1
    Next sourceRow
    
    ' 列幅を自動調整
    wsResult.Columns.AutoFit
    
    ' 日付フォーマットを設定
    With wsResult.Columns("A")
        .NumberFormat = "yyyy/mm/dd hh:mm"
    End With
    
    With wsResult.Columns("B")
        .NumberFormat = "@"
    End With
    
    With wsResult.Columns("I")
        .NumberFormat = "yyyy/mm/dd"
    End With
    
    MsgBox "データを '" & RESULT_SHEET & "' に出力しました。", vbInformation
    
Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

処理の概要

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

  1. uriage シート（売上データ）と kokyaku_daicho_Sheet1 シート（顧客データ）を取得。
  2. kokyaku_daicho_Sheet1 のデータを Scripting.Dictionary に格納。
  3. uriage シートの D列（顧客キー）を基準に顧客データを結合。
  4. purchase_month（購入月）を作成。
  5. merged_data シートに結果を出力。
  6. フォーマットと列幅の調整を実施。
  7. 処理完了メッセージを表示。

対象のシートを指定

まず、処理を行う uriage シートと kokyaku_daicho_Sheet1 シートを取得します。

Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Set wsSource = Sheets("uriage")
Set wsTarget = Sheets("kokyaku_daicho_Sheet1")
  • Dim wsSource As Worksheet で uriage シートを取得。
  • Dim wsTarget As Worksheet で kokyaku_daicho_Sheet1 シートを取得。
  • シートが存在しない場合は MsgBox で警告を出し、処理を中断。

顧客データを辞書に格納

kokyaku_daicho_Sheet1 シートの A列（顧客キー）と B～E列 の情報を辞書 (Scripting.Dictionary) に登録します。

Set sourceDict = CreateObject("Scripting.Dictionary")
For Each cell In wsTarget.Range("A2:A" & lastRowTarget)
    keyValue = cell.Value
    If Not IsEmpty(keyValue) And Not sourceDict.exists(keyValue) Then
        dataArr = wsTarget.Cells(cell.Row, 2).Resize(1, 4).Value
        sourceDict(keyValue) = dataArr
    End If
Next cell
  • CreateObject("Scripting.Dictionary") で辞書オブジェクトを作成。
  • A列（顧客キー）をキー、B～E列 のデータを値として辞書に格納。
  • Not IsEmpty(keyValue) により空白セルを除外。

データの統合と purchase_month の計算

辞書を利用し、uriage シートの D列（顧客キー）を基準に kokyaku_daicho_Sheet1 のデータを結合し、購入月を算出します。

For sourceRow = 2 To lastRowSource
    keyValue = wsSource.Cells(sourceRow, SOURCE_KEY_COLUMN).Value
    wsResult.Cells(outputRow, 1).Value = wsSource.Cells(sourceRow, 1).Value
    
    dateValue = wsSource.Cells(sourceRow, 1).Value
    If IsDate(dateValue) Then
        purchaseMonth = Year(dateValue) & Right("0" & Month(dateValue), 2)
    Else
        purchaseMonth = ""
    End If
    wsResult.Cells(outputRow, 2).Value = purchaseMonth
    
    wsResult.Cells(outputRow, 3).Value = wsSource.Cells(sourceRow, 2).Value
    wsResult.Cells(outputRow, 4).Value = wsSource.Cells(sourceRow, 3).Value
    wsResult.Cells(outputRow, 5).Value = wsSource.Cells(sourceRow, 4).Value
    
    If sourceDict.exists(keyValue) Then
        dataArr = sourceDict(keyValue)
        wsResult.Cells(outputRow, 6).Resize(1, 4).Value = dataArr
    End If
    
    outputRow = outputRow + 1
Next sourceRow
  • IsDate(dateValue) を使用して日付形式か判定し、purchase_month（購入月）を作成。
  • sourceDict.exists(keyValue) により、顧客情報を追加。

フォーマットと列幅の調整

データの視認性を向上させるため、列幅の自動調整とフォーマット設定を行います。

wsResult.Columns.AutoFit

With wsResult.Columns("A")
    .NumberFormat = "yyyy/mm/dd hh:mm"
End With

With wsResult.Columns("B")
    .NumberFormat = "@"
End With

With wsResult.Columns("I")
    .NumberFormat = "yyyy/mm/dd"
End With
  • .AutoFit で列幅を調整。
  • A列（日付）を yyyy/mm/dd hh:mm 形式に設定。
  • B列（purchase_month）を文字列として扱う。
  • I列（顧客データの日付情報）を yyyy/mm/dd 形式に設定。

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

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

MsgBox "データを 'merged_data' に出力しました。", vbInformation
  • MsgBox を使用し、処理完了を知らせるメッセージを表示。
  • vbInformation を指定して、情報メッセージとして表示。

以上で集計の準備が整いました。

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

この記事を書いた人

Katsumaのアバター Katsuma

関連記事

コメント

コメントする

目次