コラム

ChatGPTを使用して複雑なプログラミング Excel VBAで二次元の表を作成してみる

今回はChatGPTで何処まで複雑な処理のプログラムを作成する事が可能か、人間がするべき作業は何かを検証する1つの例として下記の様なプログラムの作成を試みました。

プログラム説明

生産者、カテゴリ、品種、数量という項目を持っているデータ群を、生産者の値を縦のヘッダー、カテゴリと品種の値を横のヘッダーとする表を出力する。

元のデータの項目が変わったり、ヘッダー行に使用する項目が変わる場合にも対象出来るように汎用的に使用する事も可能なVBAプログラムをChatGPTを使用して作成してみた。

① やりたい事をまとめてChatGPTに依頼してみます。

依頼内容

具体的な例を示しながら要件を書いていきます。
例1
・項目が生産者、カテゴリ、品種、数量というデータが複数存在する
・上記のデータを下記の形式でExcel表に表示したい
・行に置けるヘッダーは、生産者の値を使用する。生産者の種類分の行数が存在する。
・列に置けるヘッダーは、カテゴリ、品種の値を使用する。カテゴリの値が大項目、品種の値は中項目となる。カテゴリ、品種の種類分をグループ化した列数が存在する。
・データはカテゴリ順に並んでいないので、カテゴリ、品種順にソートする
・数量は列ヘッダーと行ヘッダーにおける適切な場所に表示する。
・生産者、カテゴリ、品種が同様のデータが存在する場合、数量を足して適切な場所に表示する。
・ピボットテーブルは使用しないでください

例2
・項目が日付、規格1、規格2、規格3、数量1,数量2というデータが複数存在する
・上記のデータを下記の形式でExcel表に表示したい
・行に置けるヘッダーは、日付の値を使用する。生産者の種類分の行数が存在する。
・列に置けるヘッダーは、規格1、規格2、規格3、の値を使用する。規格1の値が大項目、規格2の値は中項目、規格3が小項目となる。規格1、規格2、規格3の種類分をグループ化した列数が存在する。
・データは規格1、規格2に並んでいないので、規格1、規格2の順でソートする
・数量1,数量2は列ヘッダーと行ヘッダーにおける適切な場所に表示する。
・日付、規格1、規格2、規格3が同様のデータが存在する場合、数量1には数量1を数量2には数量2を足して適切な場所に表示する。
・ピボットテーブルは使用しないでください

上記はあくまで例なので、データの項目が変わったり、ヘッダーに使用するデータの項目が変わる事もあります。
この様な表を出力する事が可能なプログラムを作成して下さい

具体例を記述するのが良い気がします。
また具体例1つだと、その例に特化したものしか作成してくれないので、汎用的なプログラムにする為、具体例を2つ書いて依頼しています。
罫線表示とヘッダー部の同一の値の時のセル結合の対応は後で依頼します。

結果

以下の様なプログラムが返ってきました。
createCustomTable関数をExcelの「開発→Visual Basic」で開いたプログラム記述個所に張り付けて実行します。

Sub createCustomTable(headerRowItems As Variant, headerColumnItems As Variant)

    Dim sourceWs As Worksheet
    Set sourceWs = ThisWorkbook.Worksheets("SourceSheet")
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Clearing the existing contents of the sheet
    ws.Cells.Clear
    
    Dim dataRange As Range
    Set dataRange = sourceWs.UsedRange
    
    Dim rowHeaders As Collection
    Set rowHeaders = New Collection
    Dim columnHeaders As Collection
    Set columnHeaders = New Collection
    
    Dim dataRow As Range
    Dim dataCell As Range
    
    ' Collect unique values for headers
    On Error Resume Next
    For Each dataRow In dataRange.Rows
        Dim rowKey As String
        Dim columnKey As String
        rowKey = ""
        columnKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataRow.Cells(1, index).Value
        Next index
        For Each index In headerColumnItems
            columnKey = columnKey & "_" & dataRow.Cells(1, index).Value
        Next index
        rowHeaders.Add rowKey, rowKey
        columnHeaders.Add columnKey, columnKey
    Next dataRow
    On Error GoTo 0
    
    ' Write headers to target sheet
    Dim i As Integer
    i = 2
    Dim header As Variant
    For Each header In rowHeaders
        ws.Cells(i, 1).Value = Mid(header, 2)  ' Strip leading underscore
        i = i + 1
    Next header
    i = 2
    For Each header In columnHeaders
        ws.Cells(1, i).Value = Mid(header, 2)  ' Strip leading underscore
        i = i + 1
    Next header
    
    ' Transfer data
    For Each dataRow In dataRange.Rows
        Dim rowKey As String
        Dim columnKey As String
        rowKey = ""
        columnKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataRow.Cells(1, index).Value
        Next index
        For Each index In headerColumnItems
            columnKey = columnKey & "_" & dataRow.Cells(1, index).Value
        Next index
        Dim rowNumber As Integer
        Dim columnNumber As Integer
        rowNumber = rowHeaders(rowKey) + 1
        columnNumber = columnHeaders(columnKey) + 1
        ' Assuming that the value to be written is in the last column
        ws.Cells(rowNumber, columnNumber).Value = dataRow.Cells(1, dataRange.Columns.Count).Value
    Next dataRow

End Sub

以下の様にtestというメソッドを独自で作成し、ChatGPTから返ってきた関数を呼ぶように実装します。

Sub test()
    Dim rowHeaderItems As Variant
    rowHeaderItems = Array(1)  ' 第1列のデータを行のヘッダーとして使用します
    
    Dim columnHeaderItems As Variant
    columnHeaderItems = Array(2, 3)  ' 第2列と第3列のデータを列のヘッダーとして使用します
    
    Call createCustomTable(rowHeaderItems, columnHeaderItems)
End Sub

実行した結果が以下の通り

  • カテゴリと品種を同じセルになっている。
  • 数量がエラーで表示されない。

②ヘッダー部表示の改良依頼1

依頼内容

列ヘッダーに項目が複数指定されている場合は、2番目は1つ下の行、3番目は2つ下の行
というように階層表示をして下さい

結果

再度依頼をすると、プログラムの全体又は、修正部分が返ってくるので先ほどのプログラムを消して、新しプログラム記述を張り替えます。

実行した結果が以下の通り

  • カテゴリ、品種それぞれ別々にグループ化してしまっている。

この後、幾つか変更依頼をしましたが、修正されないのでプログラム見てみるとデータの持ち方的に求めてる動作をするのでが無理そうだったので、具体的にデータの持ち方を指定してみる。③を参照。

③ヘッダー部表示の改良依頼2(データの持ち方指定)

依頼内容

ヘッダーに使用する項目が複数指定されている場合は、各項目を"_"文字で区切って管理した方が良いと思います。今の方法だと、指定した項目でのグループされずに表示されてしまいます。
下記が現在の表示
カテゴリ1,カテゴリ2
品種1,品種2,品種3

結果

②と同じように依頼をすると、プログラムの全体又は、修正部分が返ってくるので先ほどのプログラムを消して、新しいプログラム記述を張り替えます。

実行した結果が以下の通り

  • カテゴリ、品種の値でグループ化されて2行での表示になった。
  • 生産者の表示位置が変更されていない

データの持ち方を指定しただけで、それに対応したロジックに修正されている。これは結構驚きました。

④ 行ヘッダーの表示位置の修正を依頼

依頼内容

行ヘッダーも列ヘッダーの数に合わせて、下げて表示して下さい

結果

②と同じように依頼をすると、プログラムの全体又は、修正部分が返ってくるので先ほどのプログラムを消して、新しいプログラム記述を張り替えます。

実行した結果が以下の通り

修正されました。これでヘッダー部分は大丈夫そうです。次はデータ(数量)表示部分。

⑤ 数量表示部分修正依頼1

依頼内容

数量が全く表示されないので、とりあえず漠然と表示されないと依頼してみました。

数量がエラーが出て表示されません。

結果

再度作成されたプログラムを使用しても変わらなかったのでロジックを見た所、ディクショナリに入っている値を利用して、表示する位置を決めていたのですが、ディクショナリの値にはヘッダー表示用の文字列が入っていたので、格納するロジックの変更を依頼しました。

この辺りまで来ると自分で修正した方が速いかもしれないですね。

⑥ ディクショナリ格納ロジック修正依頼

この辺りからはChatGPTが作成したコードを理解してないと出せない依頼です。
自分で作成した方が速い可能性があります。
今回は検証の為、ChatGPTに依頼して作成してもらいます。

依頼内容

下記の様なデータの持ち方に変更する。

ヘッダーのdictionaryの値にはインデックスを入れて、キーにはヘッダーの値を入れる。
ヘッダー表示はキーを使用して、数量表示の位置はインデックスを利用して下さい。

この依頼内容はデータの持ち方と使用方法を下記の様に変えてほしいという依頼です。

結果

まだ正常に出ないですが、ロジックは大まかには考えてる通りに修正されました。

実行した結果が以下の通り

⑦ 表示位置がずれている部分の修正

依頼内容


修正依頼一覧を下記に載せます

Dictionaryにキーとインデックスを設定する際、キーが重複しています。重複している場合は追加しないようにしてください
Cellsは1からなので、もうプラス1する必要がありますね
数量表示する際に、列が行ヘッダーを考慮してないです。行ヘッダー数分、横にずらす必要があります

結果

②と同じように依頼をすると、プログラムの全体又は、修正部分が返ってくるので先ほどのプログラムを消して、新しいプログラム記述を張り替えます

実行した結果が以下の通り

幾つか修正を依頼したら正常に表示されるようになりました。

⑧セル結合・罫線を引く

依頼内容

・データを表示する前に、ヘッダー部の値でソートして下さい。
・ヘッダー部を表示した後、同一行の列ヘッダの値が同じ場合、そのセルを結合して下さい。
・表示したセルに罫線を入れて下さい。

ソートの依頼は最初にも出したのですが、処理が入っていなかったので再度依頼します。

結果

②と同じように依頼をすると、プログラムの全体又は、修正部分が返ってくるので先ほどのプログラムを消して、新しいプログラム記述を張り替えます。

実行した結果が以下の通り

以上で、想定した処理をするプログラムを完成させることが出来ました。

完成したプログラム

Sub test()

    Dim rowHeaderItems As Variant
    rowHeaderItems = Array(1)  ' 第1列のデータを行のヘッダーとして使用します
    
    Dim columnHeaderItems As Variant
    columnHeaderItems = Array(2, 3)  ' 第2列と第3列のデータを列のヘッダーとして使用します
    
    Call createCustomTable(rowHeaderItems, columnHeaderItems, 4)

End Sub

Sub createCustomTable(headerRowItems As Variant, headerColumnItems As Variant, quantityColumn As Integer)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Cells.ClearContents

    Dim dataSheet As Worksheet
    Set dataSheet = ThisWorkbook.Sheets("SourceSheet")

    Dim dataRange As Range
    Set dataRange = dataSheet.UsedRange

    Dim rowHeaders As Object
    Set rowHeaders = CreateObject("Scripting.Dictionary")
    
    
    Dim columnHeaders As Object
    Set columnHeaders = CreateObject("Scripting.Dictionary")
    
    ' Same for row headers
    Dim rowIndex As Integer
    Dim columnIndex As Integer
    Dim index As Variant
    
    rowIndex = 1
    columnIndex = 1
    On Error Resume Next
    ' Build row headers
    For Each dataRow In dataRange.Rows
        Dim rowKey As String
        rowKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataRow.Cells(1, index).Value
        Next index
    
        If Not rowHeaders.exists(rowKey) Then
            rowHeaders.Add rowKey, rowIndex
            rowIndex = rowIndex + 1
        End If
    Next dataRow
    
    ' Build column headers
    For Each dataRow In dataRange.Rows
        Dim columnKey As String
        columnKey = ""
        For i = LBound(headerColumnItems) To UBound(headerColumnItems)
            columnKey = columnKey & "_" & dataRow.Cells(1, headerColumnItems(i)).Value
        Next i
    
        If Not columnHeaders.exists(columnKey) Then
            columnHeaders.Add columnKey, columnIndex
            columnIndex = columnIndex + 1
        End If
    Next dataRow


    ' Sorting column headers
    Dim sortedKeys() As Variant
    sortedKeys = columnHeaders.keys
    Call QuickSort(sortedKeys, LBound(sortedKeys), UBound(sortedKeys))
    columnHeaders.RemoveAll
    For i = LBound(sortedKeys) To UBound(sortedKeys)
        columnHeaders.Add sortedKeys(i), i + 1
    Next i



    ' Display headers
    Dim keys() As Variant
    keys = rowHeaders.keys
    For i = 1 To rowHeaders.Count
        ws.Cells(i + UBound(headerColumnItems) + 1, 1).Value = Split(keys(i - 1), "_")(1)
    Next i
    
    keys = columnHeaders.keys
    For i = 1 To columnHeaders.Count
        Dim j As Integer
        For j = 1 To UBound(headerColumnItems) + 1
            ws.Cells(j, i + 1).Value = Split(keys(i - 1), "_")(j)
        Next j
    Next i



    ' Merge cells in the column headers
    For i = 1 To UBound(headerColumnItems)
        Dim startCol As Long
        startCol = 1
        For j = 2 To columnHeaders.Count + 1
            If ws.Cells(headerRowOffset + i, j + UBound(headerRowItems)).Value <> ws.Cells(headerRowOffset + i, j + UBound(headerRowItems) - 1).Value Then
                If j - 1 > startCol Then
                    ws.Range(ws.Cells(headerRowOffset + i, startCol + UBound(headerRowItems)), ws.Cells(headerRowOffset + i, j + UBound(headerRowItems) - 1)).Merge
                End If
                startCol = j
            End If
        Next j
        If columnHeaders.Count + 1 > startCol Then
            ws.Range(ws.Cells(headerRowOffset + i, startCol + UBound(headerRowItems)), ws.Cells(headerRowOffset + i, columnHeaders.Count + 1 + UBound(headerRowItems))).Merge
        End If
    Next i



    ' Transfer data
    keys = rowHeaders.keys
    Dim keysColumns() As Variant
    keysColumns = columnHeaders.keys
    
    For Each dataRow In dataRange.Rows
        rowKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataRow.Cells(1, index).Value
        Next index
    
        columnKey = ""
        For i = LBound(headerColumnItems) To UBound(headerColumnItems)
            columnKey = columnKey & "_" & dataRow.Cells(1, headerColumnItems(i)).Value
        Next i
    
        On Error Resume Next
        Dim rowNumber As Integer
        rowNumber = rowHeaders(rowKey) + UBound(headerColumnItems) + 1
        Dim columnNumber As Integer
        columnNumber = columnHeaders(columnKey) + 1  ' Add 1 for the row header
        On Error GoTo 0
    
        If rowNumber > 0 And columnNumber > 0 Then
            If IsEmpty(ws.Cells(rowNumber, columnNumber).Value) Then
                ws.Cells(rowNumber, columnNumber).Value = dataRow.Cells(1, quantityColumn).Value
            Else
                ws.Cells(rowNumber, columnNumber).Value = ws.Cells(rowNumber, columnNumber).Value + dataRow.Cells(1, quantityColumn).Value
            End If
        End If
    Next dataRow


    Dim endRow As Integer
    Dim endColumn As Integer
    endRow = rowHeaders.Count + UBound(headerColumnItems) + 1
    endColumn = columnHeaders.Count + UBound(headerRowItems) + 1
    
    With ws.Range(ws.Cells(1, 1), ws.Cells(endRow, endColumn))
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With
End Sub

Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long

    tmpLow = inLow
    tmpHi = inHi

    pivot = vArray((inLow + inHi) \ 2)

    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend

        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend

        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend

    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

感想

  • 作成時間は自分で全て実装するより、少し早いくらい。
  • 汎用性、パフォーマンス部分に関してはまだ少し足りないと感じた。(もう少し依頼を増やすか、内容を変えるかする必要がある)
  • 今回の様な少し複雑なプログラムを作成するには、コードの理解が必要。
  • 最初の依頼の仕方によって、プログラムが大きく変わる。
  • データの持ち方を指定したら、その意味を理解しプログラムを組んできたので驚いた。
  • 上記の依頼以外でも、細かい修正依頼を少ししています。VBAの言語仕様の部分で少し間違いがあった。(指摘したら修正してくれた)
  • 複雑な処理はベース部分だけ作ってもらうのが良いと思う。

以上です。次はこのプログラムにパフォーマンス面や、行ヘッダー部分が複数になった時、データ部分が複数になった時の対応をやってみます。

他にもWebシステム作成など色々なシステムの開発コストを下げる為のツールとしての可能性を探っていきたいと思います。

この記事をシェアする
  • Facebookアイコン
  • Twitterアイコン
  • LINEアイコン

お問い合わせ ITに関するお悩み不安が少しでもありましたら、
ぜひお気軽にお問い合わせください

お客様のお悩みや不安、課題などを丁寧に、そして誠実にお伺いいたします。

お問い合わせはこちら
お電話でのお問い合わせ 03-5820-1777(平日10:00〜18:00)
よくあるご質問