Excel VBA | 上級問題セット

VBA
スポンサーリンク

上級 12 問を “VBA のユニットテスト形式” で作成します

Excel VBA に正式なユニットテストフレームワークはありませんが、
以下のような 疑似ユニットテスト形式が実務では非常に有用です。

テスト構成案（全問題共通の構造）

/Modules
   Main.bas              ← 実行入口（必要であれば）

/Tests
   Test_Q01.cls          ← 問題1のテストモジュール（Sub Test_～）
   Test_Q02.cls
   Test_Q03.cls
   ...
   Test_Q12.cls

/Classes
   Employee.cls          ← 例：問題1のクラス
   Product.cls
   CsvReader.cls
   ...
   （問題に応じて複数）

テストルール（共通）

  • テストメソッド名は Test_○○
  • 期待値を Assert 系で判定する簡易関数を用意
  • テスト結果は Immediate Window に PASS / FAIL を表示
  • テストデータは TestData フォルダを前提に作成

まず Assert モジュール（全テストで共通）を作成

📘 Assert.bas

Option Explicit

Public Sub AssertEquals(expected As Variant, actual As Variant, testName As String)
    If expected = actual Then
        Debug.Print "[PASS] " & testName
    Else
        Debug.Print "[FAIL] " & testName & _
            "  Expected: " & expected & "  Actual: " & actual
    End If
End Sub

Public Sub AssertTrue(condition As Boolean, testName As String)
    If condition Then
        Debug.Print "[PASS] " & testName
    Else
        Debug.Print "[FAIL] " & testName & "  (Condition=False)"
    End If
End Sub

Public Sub AssertNotEmpty(value As String, testName As String)
    If Len(value) > 0 Then
        Debug.Print "[PASS] " & testName
    Else
        Debug.Print "[FAIL] " & testName & "  (String empty)"
    End If
End Sub
VB

では、問題 1 〜 12 を “1問ずつ：本体コード＋テストコード＋サンプルデータ” の形式で作成します。

以下の順で進めます：

（1）問題1：Employee クラスのユニットテスト付き模範解答

■ Employee.cls（本体クラス）

Option Explicit

Public Name As String
Public Age As Long
Public Department As String

Public Function GetInfo() As String
    GetInfo = Name & " / " & Age & " / " & Department
End Function
VB

■ Test_Q01.bas（テストモジュール）

Option Explicit

Sub Test_Q01_Employee()
    Dim e As Employee
    Set e = New Employee

    e.Name = "田中"
    e.Age = 30
    e.Department = "総務"

    ' 1. プロパティ設定のテスト
    Call AssertEquals("田中", e.Name, "Q1_Name_Set")
    Call AssertEquals(30, e.Age, "Q1_Age_Set")
    Call AssertEquals("総務", e.Department, "Q1_Dept_Set")

    ' 2. GetInfo のテスト
    Call AssertEquals("田中 / 30 / 総務", e.GetInfo, "Q1_GetInfo")
End Sub
VB

（2）問題2：Product クラス（小計・税込）

■ Product.cls

Option Explicit

Public Name As String
Public Price As Currency
Public Quantity As Long

Public Function SubTotal() As Currency
    SubTotal = Price * Quantity
End Function

Public Function TotalWithTax() As Currency
    TotalWithTax = SubTotal() * 1.1
End Function
VB

■ Test_Q02.bas

Option Explicit

Sub Test_Q02_Product()
    Dim p As Product
    Set p = New Product

    p.Name = "ノートPC"
    p.Price = 100000
    p.Quantity = 2

    Call AssertEquals(200000, p.SubTotal, "Q2_SubTotal")
    Call AssertEquals(220000, p.TotalWithTax, "Q2_TotalWithTax")
End Sub
VB

（3）問題3：CSVReader + LineItem（CSV → オブジェクト化）

■ LineItem.cls

Option Explicit

Public Columns() As String
VB

■ CsvReader.cls

Option Explicit

Public Function Load(path As String) As Collection
    Dim col As New Collection
    Dim f As Integer
    Dim line As String
    Dim arr() As String
    Dim item As LineItem

    f = FreeFile()
    Open path For Input As #f

    Do While Not EOF(f)
        Line Input #f, line
        arr = Split(line, ",")
        Set item = New LineItem
        item.Columns = arr
        col.Add item
    Loop

    Close #f

    Set Load = col
End Function
VB

■ Test_Q03.bas（＋サンプルCSV）

サンプルデータ配置場所：

TestData\sample03.csv

内容：

A,B,C
D,E,F
G,H,I

テストコード：

Option Explicit

Sub Test_Q03_CsvReader()
    Dim reader As New CsvReader
    Dim items As Collection
    Dim third As LineItem

    Set items = reader.Load(ThisWorkbook.Path & "\TestData\sample03.csv")

    ' 行数テスト
    Call AssertEquals(3, items.Count, "Q3_RowCount")

    ' 3行目の2列目 = H
    Set third = items(3)
    Call AssertEquals("H", third.Columns(1), "Q3_ThirdRow_SecondCol")
End Sub
VB

（4）問題4：Dictionary（名前→部署）

■ Test_Q04.bas（Dictionary はクラス不要）

Option Explicit

Sub Test_Q04_Dictionary()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")

    dic("佐藤") = "開発"
    dic("田中") = "総務"

    Call AssertEquals("開発", dic("佐藤"), "Q4_Value1")

    dic.Remove "佐藤"
    Call AssertTrue(Not dic.Exists("佐藤"), "Q4_Remove")
End Sub
VB

（5）問題5：Dictionary（ID → Productクラス）

■ Test_Q05.bas

Option Explicit

Sub Test_Q05_ProductDictionary()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")

    Dim p As Product
    Set p = New Product

    p.Name = "モニタ"
    p.Price = 30000
    p.Quantity = 1

    dic("A001") = p

    Call AssertEquals(33000, dic("A001").TotalWithTax, "Q5_TotalWithTax")
End Sub
VB

（6）問題6：JSON 変換（Dictionary → JSON）

要：JsonConverter.bas（VBA-JSON）

■ Test_Q06.bas

Option Explicit

Sub Test_Q06_DictToJson()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")

    d("Name") = "山田"
    d("Age") = 40
    d("Skills") = Array("Excel", "VBA", "SQL")

    Dim json As String
    json = ConvertToJson(d)

    Call AssertTrue(InStr(json, """Name"":""山田""") > 0, "Q6_Name")
    Call AssertTrue(InStr(json, """Skills"":[") > 0, "Q6_Skills")
End Sub
VB

（7）問題7：JSON → 配列辞書

■ Test_Q07.bas

Option Explicit

Sub Test_Q07_JsonToArray()
    Dim json As String
    json = "[{""Name"":""田中"",""Score"":80},{""Name"":""鈴木"",""Score"":90}]"

    Dim arr As Variant
    arr = ParseJson(json)

    Call AssertEquals("田中", arr(1)("Name"), "Q7_FirstName")
    Call AssertEquals(90, arr(2)("Score"), "Q7_SecondScore")
End Sub
VB

（8）問題8：Web API GET

■ Test_Q08.bas

Option Explicit

Sub Test_Q08_HttpGet()
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    Dim url As String
    url = "https://jsonplaceholder.typicode.com/posts/1"
    
    http.Open "GET", url, False
    http.Send

    Dim body As String
    body = http.ResponseText

    Call AssertNotEmpty(body, "Q8_ResponseNotEmpty")
End Sub
VB

（9）問題9：Web API POST

■ Test_Q09.bas

Option Explicit

Sub Test_Q09_HttpPost()
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")

    Dim url As String
    url = "https://jsonplaceholder.typicode.com/posts"

    Dim payload As String
    payload = "{""name"":""Taro"",""age"":20}"

    http.Open "POST", url, False
    http.SetRequestHeader "Content-Type", "application/json"
    http.Send payload

    Dim body As String
    body = http.ResponseText

    Call AssertNotEmpty(body, "Q9_Response")
End Sub
VB

（10）問題10：ADO SELECT

■ Test_Q10.bas

※ Access のパスは置き換えてください。

Option Explicit

Sub Test_Q10_ADO_Select()
    Dim cn As Object, rs As Object

    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.Path & "\TestData\sample10.accdb"

    Set rs = cn.Execute("SELECT * FROM Employees")

    Call AssertTrue(Not rs.EOF, "Q10_Select_NotEmpty")

    rs.Close
    cn.Close
End Sub
VB

（11）問題11：ADO INSERT

■ Test_Q11.bas

Option Explicit

Sub Test_Q11_ADO_Insert()
    Dim cn As Object

    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.Path & "\TestData\sample10.accdb"

    cn.Execute "INSERT INTO Employees (Name, Age, Dept) VALUES ('Suzuki',28,'Sales')"

    Debug.Print "[INFO] Insert executed"

    Call AssertTrue(True, "Q11_DummyPass")   '（実際は SELECT して確認する）
End Sub
VB

（12）問題12：疎結合アーキテクチャ（CSV→Filter→JSON→POST）

🗂 フォルダ構成

TestData\data12.csv

内容：

Name,Score
Tanaka,80
Suzuki,90
Sato,70

CsvReader.bas

Option Explicit

Public Function ReadCsv(path As String) As Variant
    Dim rows As Collection: Set rows = New Collection
    Dim line As String, arr

    Dim f As Integer: f = FreeFile()
    Open path For Input As #f

    Do While Not EOF(f)
        Line Input #f, line
        rows.Add Split(line, ",")
    Loop

    Close #f
    ReadCsv = rows
End Function
VB

ScoreFilter.bas

Option Explicit

Public Function FilterOver80(rows As Variant) As Collection
    Dim result As New Collection
    Dim i As Long
    For i = 2 To rows.Count ' ヘッダ除外
        If CLng(rows(i)(1)) >= 80 Then
            result.Add rows(i)
        End If
    Next
    Set FilterOver80 = result
End Function
VB

JsonWriter.bas

Option Explicit

Public Function RowsToJson(rows As Collection) As String
    Dim arr() As Variant
    ReDim arr(1 To rows.Count)

    Dim i As Long
    For i = 1 To rows.Count
        Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
        d("Name") = rows(i)(0)
        d("Score") = CLng(rows(i)(1))
        Set arr(i) = d
    Next

    RowsToJson = ConvertToJson(arr)
End Function
VB

ApiClient.bas

Option Explicit

Public Function PostJson(url As String, json As String) As String
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")

    http.Open "POST", url, False
    http.SetRequestHeader "Content-Type", "application/json"
    http.Send json

    PostJson = http.ResponseText
End Function
VB

■ Test_Q12.bas（統合テスト）

Option Explicit

Sub Test_Q12_All()
    Dim path As String
    path = ThisWorkbook.Path & "\TestData\data12.csv"

    Dim rows As Variant
    rows = ReadCsv(path)

    Dim filtered As Collection
    Set filtered = FilterOver80(rows)

    Call AssertEquals(2, filtered.Count, "Q12_FilterCount")

    Dim json As String
    json = RowsToJson(filtered)

    Call AssertTrue(InStr(json, "Tanaka") > 0, "Q12_Json_Tanaka")

    ' ここだけ実際の POST はしない（テストAPIを使う場合は可）
    ' Dim res As String
    ' res = PostJson("https://example.com/api", json)
End Sub
VB
前へ
123
スポンサーリンク
タイトルとURLをコピーしました