四列（x，y，z，值）到矩阵表的表

Question

我想将四列中的数据转换为矩阵表。我尝试使用 OFFSET 函数并且它可以工作，但是我的数据太大（大约 100,000 个单元格）并且它崩溃了。

所以，我很想尝试通过宏来执行此操作，您能建议如何执行此操作吗？或者您有任何更好的建议。

PS。我使用了这个网站上的 OFFSET 公式here。

Answer 1

在 ROWS 的齿轮上方的类型、COLUMNS 的颜色和 Σ VALUES 的金额总和中枢轴：

隐藏顶行，以表格形式显示报表布局，删除所有小计和总计，重新排列列和行的顺序，设置空单元格以显示 0，隐藏展开/折叠按钮，重复所有项目标签设置*，并添加了边框。

为了显示0s 的行，我在源数据中添加了 Bus/Green/Manual（使用颜色（绿色）以避免（空白）作为额外的列）。

---

* 在 Excel 2007 中不可用。要为早于 Excel 2010 的版本重复项目标签，标准做法是复制 PT 并粘贴特殊值，然后通过选择它们来填充空白 Go To Special, Blanks then @ 987654326@，向上，Ctrl+Enter。

Answer 2

有趣的问题！因为您遇到了涉及数据大小的问题，所以我尽量避免使用字典之类的对象（我不知道字典可以容纳多少）。相反，我创建了一个程序来跟踪非常少的数据，但最终会不断地从文件中读取/写入：它会很慢，但它适用于非常大的文件。

无论如何，请尝试将以下代码复制并粘贴到 VBA 模块中，然后在您的文件上运行它。您可能需要更改行和列的一些值。

编辑：我使它适用于您提供的示例图片，但它一团糟。明天我会尽量让它更清楚（g2g）
编辑：它已更新！仔细注释等，随心所欲地修改。

总结

• 在数据表下方构建矩阵表
• 循环遍历数据表的行并将它们添加到矩阵表中
• 如果矩阵表还没有数据的行或列，则创建它，否则放入现有的

示例：

代码：（所以去掉了空格：（我觉得我的帖子太长了）

'Start and end row of the original data
Private dataStartRow As Long
Private dataEndRow As Long

'The start row/column of the matrix
Private matrixStartRow As Long
Private matrixStartCol As Long

'How many rows/columns in the matrix
Private matrixRowLength As Long
Private matrixColLength As Integer

Public Sub makeMatrixTable()
    'Sets initial values for variables
    initializeValues
    'Builds table
    buildTable
End Sub

Private Function initializeValues()
    'The actual data probably begins on row 2, because row 1 is usually used for column titles
    dataStartRow = 2
    'Get last row of data
    dataEndRow = ActiveSheet.UsedRange.Rows.Count

    'By adding 2, we create a gap row between our new matrix table and the original data table
    matrixStartRow = dataEndRow + 2
    'The matrix values begin after column 2, because columns 1&2 are used for titles
    matrixStartCol = 2

    matrixRowLength = 0
    matrixColLength = 0
End Function

Private Function buildTable()
    Dim dataRow As Long
    Dim matrixRow As Long
    Dim matrixCol As Integer
    Dim value As String

    'The keys are the column/row titles
    'I'm using the work "key" because we're mimicking a dictionary object by only using a key once
    'in this case it's a little more complicated, as we have 3 keys (2 row keys, 1 column key)
    Dim rowKey1 As String, rowKey2 As String
    Dim colKey As String

    'loop through all rows containing data
    For dataRow = dataStartRow To dataEndRow
        'get keys from data
        rowKey1 = CStr(ActiveSheet.Cells(dataRow, 1).value)
        rowKey2 = CStr(ActiveSheet.Cells(dataRow, 3).value)
        colKey = CStr(ActiveSheet.Cells(dataRow, 2).value)

        'find if we have already created rows for the row keys, and if so return the row (else -1)
        matrixRow = rowExistsInMatrix(rowKey1, rowKey2)
        'find if we have already created a column for the column key, and if so return the row (else -1
        matrixCol = colExistsInMatrix(colKey)

        'Our matrix does not have a row with those row keys, so we must create one
        If matrixRow = -1 Then
            'increase the size of our matrix
            matrixRowLength = matrixRowLength + 1
            'get row that is not in use
            matrixRow = matrixStartRow + matrixRowLength
            'add the new keys to matrix
            ActiveSheet.Cells(matrixRow, 1).value = rowKey1
            ActiveSheet.Cells(matrixRow, 2).value = rowKey2
        End If

        'We don't have a column that matches the column key
        If matrixCol = -1 Then
            'increase size of matrix table
            matrixColLength = matrixColLength + 1
            'get column that is not in use
            matrixCol = matrixStartCol + matrixColLength
            'add new key to matrix
            ActiveSheet.Cells(matrixStartRow, matrixCol).value = colKey
        End If

        'get the value to be placed in the matrix from column 4
        value = CStr(ActiveSheet.Cells(dataRow, 4).value)
        'place value
        ActiveSheet.Cells(matrixRow, matrixCol).value = value

    Next dataRow
End Function

'Checks to see if the key from the data table exists in our matrix table
'if it does, return the row in the matrix table
'else return -1
Private Function rowExistsInMatrix(dataKey1 As String, dataKey2 As String) As Long
    Dim matrixRow As Long
    Dim matrixKey1 As String, matrixKey2 As String

    'loop through rows of matrix
    For matrixRow = matrixStartRow To matrixStartRow + matrixRowLength
        'get keys from matrix
        matrixKey1 = CStr(ActiveSheet.Cells(matrixRow, 1).value)
        matrixKey2 = CStr(ActiveSheet.Cells(matrixRow, 2).value)

        'do the keys match
        If dataKey1 = matrixKey1 And dataKey2 = matrixKey2 Then
            rowExistsInMatrix = matrixRow
            Exit Function
        End If
    Next matrixRow

    rowExistsInMatrix = -1
End Function

'Same as rowExistsInMatrix but loops through column titles
Private Function colExistsInMatrix(dataKey As String) As Long
    Dim matrixKey As String
    Dim matrixCol As Integer

    'loop through columns
    For matrixCol = matrixStartCol To matrixStartCol + matrixColLength
        matrixKey = CStr(ActiveSheet.Cells(matrixStartRow, matrixCol).value)

        'does a key match
        If matrixKey = dataKey Then
            colExistsInMatrix = matrixCol
            Exit Function
        End If
    Next matrixCol

    colExistsInMatrix = -1
End Function