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

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

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

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

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

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

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

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

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

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

ヘッダーの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