コラム

ChatGPTを使用して複雑なプログラミング Excel VBAで二次元の表を作成してみる(パフォーマンスアップ等)

前回の続きです。今回は次の機能、修正を加えていきたいと思います。

  • 行ヘッダー部も複数項目に対応
  • データ表示時のパフォーマンスアップ対応

以下の図の様に表示され、パフォーマンスアップも実現したい。

① 行ヘッダー部も複数項目への対応依頼

依頼内容

行ヘッダーも複数設定可能にしたい。
複数指定された場合は、横列にずらして表示するようにして下さい。

結果

  • セル結合と罫線がなくなってしまった。
  • ヘッダー部分の表示は思ったように出来ている。
  • 数量の表示で「型エラーが一致しない」というエラーが発生する。

セル結合と罫線は後で依頼します。
エラーに関してはエラーの発生個所を指定して修正依頼をしてみます。

② 数量表示エラーの修正依頼1

依頼内容

<code>
ws.Cells(rowNumber, columnNumber).Value = ws.Cells(rowNumber, columnNumber).Value + dataRow.Cells(1, quantityColumn).Value 
</code>
<code>タグ内の個所でで型エラーが発生したので、修正して下さい。

結果

  • 何回かやり取りしたのですが、解消されない。

エラーが解消されないので、コードを見てもう少し具体的に指摘してみます。

③ 数量表示エラーの修正依頼

エラーが解消されないので、コードを見てもう少し具体的に指摘してみます。

依頼内容

表示しようとしているセルには行ヘッダーの値が入っています。
行ヘッダー数分、表示列をずらす必要があります。

結果

  • 数量が正常に表示されるようになりました。
  • この辺りになるとコードを読む能力が必要です。

③ 処理速度向上対応

現在のコードは、データ取得時、データ表示に都度セルにアクセスしていたので、データが多い場合処理速度が遅くなってしまいますので、その部分の対応を依頼してみます。

依頼内容

<code>
 Sub createCustomTable2(headerRowItems As Variant, headerColumnItems As Variant, quantityColumn As Integer)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Cells.ClearContents
    ...省略
</code>
タグ内のプログラムをセルへのアクセスを極力少なくして処理速度を向上させてください

<code>タグ内に現在のコードを張り付け、修正依頼を出しています。

結果

  • 取得時には対象データを全て二次元配列に格納、表示時にも二次元配列を用意し、データ格納後に表示するように改修されていた。
  • ヘッダーの表示処理が抜けている。
  • ヘッダーソート処理が抜けている。

④ ヘッダーソート・表示処理追加

依頼内容

行ヘッダー、列ヘッダーのソート処理を入れて下さい。

結果

  • ヘッダーが表示されました。


後はセル結合と罫線表示だけです。

⑤ セル結合・罫線表示1

依頼内容

・表示したヘッダー、数量部分の罫線表示をして下さい。
・列ヘッダーであれば隣のセルの値と同じであれば結合、
 行ヘッダーであれば、下のセルの値と同じであれば結合するようにして下さい。

結果

  • カテゴリ2、生産者2が結合されていない
  • 罫線は正常に表示されている

2つ目以降も結合されるように依頼してみます。

⑥ セル結合・罫線表示2

カテゴリ2、生産者2が結合されていないので、その対応をします。

依頼内容

1つ目は結合されますが、2つ目が結合されません

結果

正常に表示されました。これで課題は全て完了しました。

完成したプログラム

Sub test()

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

End Sub

Sub createCustomTable(headerRowItems As Variant, headerColumnItems As Variant, quantityColumn As Integer)
    Dim dataSheet As Worksheet
    Set dataSheet = ThisWorkbook.Sheets("SourceSheet")

    Dim dataValues As Variant
    dataValues = dataSheet.UsedRange.Value ' Get all data from the sheet at once
    
    Dim rowHeaders As Object
    Set rowHeaders = CreateObject("Scripting.Dictionary")

    Dim columnHeaders As Object
    Set columnHeaders = CreateObject("Scripting.Dictionary")

    ' Building row and column headers
    Dim index As Variant
    Dim rowKey As String, columnKey As String
    For i = 1 To UBound(dataValues, 1)
        rowKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataValues(i, index)
        Next index

        If Not rowHeaders.exists(rowKey) Then
            rowHeaders.Add rowKey, rowHeaders.Count + 1
        End If
        
        columnKey = ""
        For j = LBound(headerColumnItems) To UBound(headerColumnItems)
            columnKey = columnKey & "_" & dataValues(i, headerColumnItems(j))
        Next j

        If Not columnHeaders.exists(columnKey) Then
            columnHeaders.Add columnKey, columnHeaders.Count + 1
        End If
    Next i
    
    
   ' Sorting headers
    Dim sortedRowKeys() As Variant
    sortedRowKeys = rowHeaders.keys
    Call BubbleSort(sortedRowKeys)
    rowHeaders.RemoveAll
    For i = LBound(sortedRowKeys) To UBound(sortedRowKeys)
        rowHeaders.Add sortedRowKeys(i), i + 1
    Next i

    Dim sortedColumnKeys() As Variant
    sortedColumnKeys = columnHeaders.keys
    Call BubbleSort(sortedColumnKeys)
    columnHeaders.RemoveAll
    For i = LBound(sortedColumnKeys) To UBound(sortedColumnKeys)
        columnHeaders.Add sortedColumnKeys(i), i + 1
    Next i
    
    ' Initializing output array
    Dim tableArray() As Variant
    ReDim tableArray(1 To rowHeaders.Count + UBound(headerColumnItems) + 1, 1 To columnHeaders.Count + UBound(headerRowItems) + 1)

    ' Writing data to the array
    Dim totalQuantity As Double
    For i = 1 To UBound(dataValues, 1)
        rowKey = ""
        For Each index In headerRowItems
            rowKey = rowKey & "_" & dataValues(i, index)
        Next index

        columnKey = ""
        For j = LBound(headerColumnItems) To UBound(headerColumnItems)
            columnKey = columnKey & "_" & dataValues(i, headerColumnItems(j))
        Next j

        If IsEmpty(tableArray(rowHeaders(rowKey) + UBound(headerColumnItems) + 1, columnHeaders(columnKey) + UBound(headerRowItems) + 1)) Then
            tableArray(rowHeaders(rowKey) + UBound(headerColumnItems) + 1, columnHeaders(columnKey) + UBound(headerRowItems) + 1) = dataValues(i, quantityColumn)
        Else
            tableArray(rowHeaders(rowKey) + UBound(headerColumnItems) + 1, columnHeaders(columnKey) + UBound(headerRowItems) + 1) = tableArray(rowHeaders(rowKey) + UBound(headerColumnItems) + 1, columnHeaders(columnKey) + UBound(headerRowItems) + 1) + dataValues(i, quantityColumn)
        End If
    Next i

    ' Writing headers to the output array
    Dim keys() As Variant
    keys = rowHeaders.keys
    For i = 1 To rowHeaders.Count
        Dim rowKeyParts() As String
        rowKeyParts = Split(keys(i - 1), "_")
        For j = 1 To UBound(rowKeyParts)
            tableArray(i + UBound(headerColumnItems) + 1, j) = rowKeyParts(j)
        Next j
    Next i

    keys = columnHeaders.keys
    For i = 1 To columnHeaders.Count
        Dim columnKeyParts() As String
        columnKeyParts = Split(keys(i - 1), "_")
        For j = 1 To UBound(columnKeyParts)
            tableArray(j, i + UBound(headerRowItems) + 1) = columnKeyParts(j)
        Next j
    Next i

    ' Writing output to the worksheet
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Cells.ClearContents
    ws.Range(ws.Cells(1, 1), ws.Cells(rowHeaders.Count + UBound(headerColumnItems) + 1, columnHeaders.Count + UBound(headerRowItems) + 1)).Value = tableArray


    Set ws = ActiveSheet

    keys = rowHeaders.keys
    For j = 1 To UBound(Split(keys(0), "_")) - 1
        Dim startMerge As Integer
        startMerge = 1
        For i = 2 To rowHeaders.Count
            If ws.Cells(i + UBound(headerColumnItems) + 1, j).Value <> ws.Cells(i + UBound(headerColumnItems), j).Value Then
                ws.Range(ws.Cells(startMerge + UBound(headerColumnItems) + 1, j), ws.Cells(i + UBound(headerColumnItems), j)).Merge
                startMerge = i
            End If
        Next i
        ws.Range(ws.Cells(startMerge + UBound(headerColumnItems) + 1, j), ws.Cells(rowHeaders.Count + UBound(headerColumnItems) + 1, j)).Merge
    Next j

    keys = columnHeaders.keys
    For j = 1 To UBound(Split(keys(0), "_")) - 1
        startMerge = 1
        For i = 2 To columnHeaders.Count
            If ws.Cells(j, i + UBound(headerRowItems) + 1).Value <> ws.Cells(j, i + UBound(headerRowItems)).Value Then
                ws.Range(ws.Cells(j, startMerge + UBound(headerRowItems) + 1), ws.Cells(j, i + UBound(headerRowItems))).Merge
                startMerge = i
            End If
        Next i
        ws.Range(ws.Cells(j, startMerge + UBound(headerRowItems) + 1), ws.Cells(j, columnHeaders.Count + UBound(headerRowItems) + 1)).Merge
    Next j
    
        ' Apply borders only to the table range
    Dim tableRange As Range
    Set tableRange = ws.Range(ws.Cells(1, 1), ws.Cells(rowHeaders.Count + UBound(headerColumnItems) + 1, columnHeaders.Count + UBound(headerRowItems) + 1))
    tableRange.Borders.LineStyle = xlContinuous


End Sub

Sub BubbleSort(arr() As Variant)
    Dim temp As Variant
    Dim i As Long, j As Long
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
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

感想

  • 細部でミスがありエラーが出る個所がありますがやはりベース部分を作成するのは早いと思いました。
  • 処理速度の向上に関しては、二次元配列に値を格納する方法を採用しロジックも正常に動作したので、非常に便利だと思いました。
  • ヘッダー部のセル結合部分は多少やり取りをしましたが、支持の仕方によっては一発で出来るかもしれません。最終的には思った通りのものが出来ました。
  • 前回も書きましたが、複雑な処理はベース部分だけ作ってもらうのが良い方法でミスの個所は人間が修正するのが良いではと思いました。
  • 修正依頼をすると以前あった処理が無くなる事があるので、全てChatGPTで作成するのは複雑なプログラムでは向いてないのかもしれません。

以上、非常に面白い試みでしたが、思った以上に此方の意図を組んで作成してくれるので、上手く使えば協力なツールになると思います。
今後も他の言語やフレームワークでのアプリ、システム作成をChatGPTを利用して作成し公開していきたいと思います。

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

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

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

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