Excel VBA | 中級・上級 VBA 総合セット（100問） | ページ 11

VBA 応用実務課題（統合問題）10問＋解答解説

VBA 応用実務課題（統合問題）10問＋解答解説

ここでは 複数のテクニックを組み合わせた実務課題をテーマにした 10 問を用意し、模範コードと解説を添えています。「配列」「Dictionary」「イベント」「高速化」「ファイル入出力」などを総合的に活用する練習です。

Q1. 複数シートの売上データを配列に読み込み、商品別に合計を計算して新しいシートに出力せよ

解答例

Sub ConsolidateSales()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long, lastRow As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Sales*" Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            arr = ws.Range("A2:B" & lastRow).Value
            
            For i = 1 To UBound(arr, 1)
                If dict.Exists(arr(i, 1)) Then
                    dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, 2)
                Else
                    dict(arr(i, 1)) = arr(i, 2)
                End If
            Next i
        End If
    Next ws
    
    Sheets.Add.Name = "Summary"
    Dim r As Long: r = 2
    For Each i In dict.Keys
        Sheets("Summary").Cells(r, 1).Value = i
        Sheets("Summary").Cells(r, 2).Value = dict(i)
        r = r + 1
    Next i
End Sub

Sub ConsolidateSales()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long, lastRow As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Sales*" Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            arr = ws.Range("A2:B" & lastRow).Value
            
            For i = 1 To UBound(arr, 1)
                If dict.Exists(arr(i, 1)) Then
                    dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, 2)
                Else
                    dict(arr(i, 1)) = arr(i, 2)
                End If
            Next i
        End If
    Next ws
    
    Sheets.Add.Name = "Summary"
    Dim r As Long: r = 2
    For Each i In dict.Keys
        Sheets("Summary").Cells(r, 1).Value = i
        Sheets("Summary").Cells(r, 2).Value = dict(i)
        r = r + 1
    Next i
End Sub

解説:
複数シート → 配列 → Dictionary で商品別集計 → 新シートに出力。月別売上統合に直結。

Q2. 顧客リストから「東京」「大阪」など地域別に分類し、Dictionary に格納して集計せよ

解答例

Sub RegionSummary()
    Dim arr As Variant, dict As Object, i As Long
    arr = Range("A2:B100").Value   'A列=顧客名, B列=地域
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 2)) Then
            dict(arr(i, 2)) = dict(arr(i, 2)) + 1
        Else
            dict(arr(i, 2)) = 1
        End If
    Next i
    
    Dim r As Long: r = 2
    For Each i In dict.Keys
        Cells(r, 4).Value = i
        Cells(r, 5).Value = dict(i)
        r = r + 1
    Next i
End Sub

Sub RegionSummary()
    Dim arr As Variant, dict As Object, i As Long
    arr = Range("A2:B100").Value   'A列=顧客名, B列=地域
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 2)) Then
            dict(arr(i, 2)) = dict(arr(i, 2)) + 1
        Else
            dict(arr(i, 2)) = 1
        End If
    Next i
    
    Dim r As Long: r = 2
    For Each i In dict.Keys
        Cells(r, 4).Value = i
        Cells(r, 5).Value = dict(i)
        r = r + 1
    Next i
End Sub

解説:
地域をキーにして顧客数を集計。営業戦略やマーケティング分析に活用可能。

Q3. 在庫表を読み込み、在庫数が閾値以下なら警告メッセージを表示せよ

解答例

Sub CheckStock()
    Dim arr As Variant, i As Long
    arr = Range("A2:C50").Value   'A=商品, B=在庫数, C=閾値
    
    For i = 1 To UBound(arr, 1)
        If IsNumeric(arr(i, 2)) And IsNumeric(arr(i, 3)) Then
            If arr(i, 2) < arr(i, 3) Then
                MsgBox arr(i, 1) & " の在庫が不足しています"
            End If
        End If
    Next i
End Sub

Sub CheckStock()
    Dim arr As Variant, i As Long
    arr = Range("A2:C50").Value   'A=商品, B=在庫数, C=閾値
    
    For i = 1 To UBound(arr, 1)
        If IsNumeric(arr(i, 2)) And IsNumeric(arr(i, 3)) Then
            If arr(i, 2) < arr(i, 3) Then
                MsgBox arr(i, 1) & " の在庫が不足しています"
            End If
        End If
    Next i
End Sub

解説:
在庫数と閾値を比較して不足を警告。欠品防止に直結。

Q4. 複数ブックのデータを統合し、ピボットテーブルを自動作成せよ

解答例

Sub PivotFromBooks()
    Dim wb As Workbook, ws As Worksheet
    Dim fName As String, destWs As Worksheet
    
    Set destWs = ThisWorkbook.Sheets.Add
    destWs.Name = "PivotSource"
    
    fName = Dir("C:\Users\Public\Data\*.xlsx")
    Do While fName <> ""
        Set wb = Workbooks.Open("C:\Users\Public\Data\" & fName)
        wb.Sheets(1).Range("A1:C20").Copy destWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        wb.Close False
        fName = Dir
    Loop
    
    'ピボット作成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ThisWorkbook.PivotCaches.Create(xlDatabase, destWs.Range("A1").CurrentRegion)
    Set pt = pc.CreatePivotTable(TableDestination:=Sheets.Add.Range("A3"), TableName:="SalesPivot")
    
    With pt
        .PivotFields("商品").Orientation = xlRowField
        .PivotFields("売上").Orientation = xlDataField
    End With
End Sub

Sub PivotFromBooks()
    Dim wb As Workbook, ws As Worksheet
    Dim fName As String, destWs As Worksheet
    
    Set destWs = ThisWorkbook.Sheets.Add
    destWs.Name = "PivotSource"
    
    fName = Dir("C:\Users\Public\Data\*.xlsx")
    Do While fName <> ""
        Set wb = Workbooks.Open("C:\Users\Public\Data\" & fName)
        wb.Sheets(1).Range("A1:C20").Copy destWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        wb.Close False
        fName = Dir
    Loop
    
    'ピボット作成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ThisWorkbook.PivotCaches.Create(xlDatabase, destWs.Range("A1").CurrentRegion)
    Set pt = pc.CreatePivotTable(TableDestination:=Sheets.Add.Range("A3"), TableName:="SalesPivot")
    
    With pt
        .PivotFields("商品").Orientation = xlRowField
        .PivotFields("売上").Orientation = xlDataField
    End With
End Sub

解説:
複数ブック → 統合 → ピボットテーブル生成。大量データ分析を自動化。

Q5. ユーザーフォームで検索機能を作り、商品コードを入力すると詳細情報を表示せよ

解答例

Private Sub CommandButton1_Click()
    Dim code As String, r As Range
    code = Me.TextBox1.Value
    
    Set r = Sheets("商品マスタ").Range("A:A").Find(code, LookAt:=xlWhole)
    If Not r Is Nothing Then
        Me.Label1.Caption = "商品名: " & r.Offset(0, 1).Value & vbCrLf & _
                            "価格: " & r.Offset(0, 2).Value
    Else
        Me.Label1.Caption = "該当なし"
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim code As String, r As Range
    code = Me.TextBox1.Value
    
    Set r = Sheets("商品マスタ").Range("A:A").Find(code, LookAt:=xlWhole)
    If Not r Is Nothing Then
        Me.Label1.Caption = "商品名: " & r.Offset(0, 1).Value & vbCrLf & _
                            "価格: " & r.Offset(0, 2).Value
    Else
        Me.Label1.Caption = "該当なし"
    End If
End Sub

解説:
フォーム入力 → Find 検索 → Label に結果表示。ユーザーインターフェース強化に直結。

Q6. イベント処理で入力チェックを行い、誤入力を防止せよ

解答例

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B2:B100")) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "数値を入力してください"
            Application.EnableEvents = False
            Target.ClearContents
            Application.EnableEvents = True
        End If
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B2:B100")) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "数値を入力してください"
            Application.EnableEvents = False
            Target.ClearContents
            Application.EnableEvents = True
        End If
    End If
End Sub

解説:
イベントで入力チェックを行い、誤入力を削除。大量データ入力時の品質管理に有効。

Q7. ファイル入出力でログを残し、処理履歴を管理せよ

解答例

Sub WriteLog()
    Dim fNum As Integer
    fNum = FreeFile
    Open "C:\Users\Public\processlog.txt" For Append As #fNum
    Print #fNum, Now & " - 売上集計処理完了"
    Close #fNum
End Sub

Sub WriteLog()
    Dim fNum As Integer
    fNum = FreeFile
    Open "C:\Users\Public\processlog.txt" For Append As #fNum
    Print #fNum, Now & " - 売上集計処理完了"
    Close #fNum
End Sub

解説:
ログファイルに処理履歴を追記。監査やトラブル対応に役立つ。

Q8. 高速化テクニックを組み合わせて、数万行のデータを処理せよ

解答例

Sub FastProcess()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim arr As Variant, i As Long
    arr = Range("A2:A50000").Value
    
    For i = 1 To UBound(arr, 1)
        If IsNumeric(arr(i, 1)) Then arr(i, 1) = arr(i, 1) * 2
    Next i
    
    Range("A2:A50000").Value = arr
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub FastProcess()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim arr As Variant, i As Long
    arr = Range("A2:A50000").Value
    
    For i = 1 To UBound(arr, 1)
        If IsNumeric(arr(i, 1)) Then arr(i, 1) = arr(i, 1) * 2
    Next i
    
    Range("A2:A50000").Value = arr
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

解説:
画面更新・計算・イベントを止めて配列処理 → 爆速化。数万行でも実用的。

Q9. エラー処理を組み込み、異常終了を防げ

解答例

Sub SafeProcess()
    On Error GoTo ErrHandler
    
    Dim wb As Workbook
    Set wb = Workbooks.Open("C:\Users\Public\data.xlsx")
    wb.Sheets(1).Range("A1").Value = "OK"
    wb.Close SaveChanges:=True
    
    Exit Sub
    
ErrHandler:
    MsgBox "処理中にエラーが発生しました: " & Err.Description
End Sub

Sub SafeProcess()
    On Error GoTo ErrHandler
    
    Dim wb As Workbook
    Set wb = Workbooks.Open("C:\Users\Public\data.xlsx")
    wb.Sheets(1).Range("A1").Value = "OK"
    wb.Close SaveChanges:=True
    
    Exit Sub
    
ErrHandler:
    MsgBox "処理中にエラーが発生しました: " & Err.Description
End Sub

解説:
エラー処理を組み込むことで異常終了を防ぎ、ユーザーにメッセージを返せる。

Q10. 上記すべてを組み合わせた「売上管理システム」を構築せよ

解答例（統合イメージ）

Sub SalesSystem()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    '売上データ集計
    Dim ws As Worksheet, arr As Variant, dict As Object, i As Long, lastRow As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Sales*" Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            arr = ws.Range("A2:B" & lastRow).Value
            For i = 1 To UBound(arr, 1)
                If dict.Exists(arr(i, 1)) Then
                    dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, 2)
                Else
                    dict(arr(i, 1)) = arr(i, 2)
                End If
            Next i
        End If
    Next ws
    
    '結果出力
    Dim r As Long: r = 2
    Sheets.Add.Name = "Summary"
    For Each i In dict.Keys
        Sheets("Summary").Cells(r, 1).Value = i
        Sheets("Summary").Cells(r, 2).Value = dict(i)
        r = r + 1
    Next i
    
    'ログ出力
    Dim fNum As Integer
    fNum = FreeFile
    Open "C:\Users\Public\saleslog.txt" For Append As #fNum
    Print #fNum, Now & " - 売上集計完了"
    Close #fNum
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    MsgBox "エラー発生: " & Err.Description
End Sub

Sub SalesSystem()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    '売上データ集計
    Dim ws As Worksheet, arr As Variant, dict As Object, i As Long, lastRow As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Sales*" Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            arr = ws.Range("A2:B" & lastRow).Value
            For i = 1 To UBound(arr, 1)
                If dict.Exists(arr(i, 1)) Then
                    dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, 2)
                Else
                    dict(arr(i, 1)) = arr(i, 2)
                End If
            Next i
        End If
    Next ws
    
    '結果出力
    Dim r As Long: r = 2
    Sheets.Add.Name = "Summary"
    For Each i In dict.Keys
        Sheets("Summary").Cells(r, 1).Value = i
        Sheets("Summary").Cells(r, 2).Value = dict(i)
        r = r + 1
    Next i
    
    'ログ出力
    Dim fNum As Integer
    fNum = FreeFile
    Open "C:\Users\Public\saleslog.txt" For Append As #fNum
    Print #fNum, Now & " - 売上集計完了"
    Close #fNum
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    MsgBox "エラー発生: " & Err.Description
End Sub