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

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

<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>
タグ内のプログラムをセルへのアクセスを極力少なくして処理速度を向上させてください

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

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

１つ目は結合されますが、２つ目が結合されません

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