Vba 四列表（x、y、z、值）到矩阵表

我想将四列中的数据转换为矩阵表。我试着使用偏移函数，但我的数据太大（大约100000个单元格），它崩溃了

所以，我想试着用宏来做这个，你能建议怎么做吗？或者你有更好的建议，那就太好了

另外，我使用了这个网站的补偿公式

---

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

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

编辑：我为你提供的示例图片制作了它，但它是一团乱。明天（g2g）我会尽量讲清楚的
编辑：已经更新了！仔细评论等，它将很容易修改，但你喜欢

总结

• 在数据表下面建立矩阵表
• 循环遍历数据表的行，并将它们添加到矩阵表中
• 如果矩阵表中还没有数据行或数据列，则将其设置为现有行或数据列，否则将其放置在现有行或数据列中

示例：

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

---

在行、列的颜色和∑值的金额总和上旋转类型：

隐藏顶行，以表格形式显示报告布局，删除所有小计和总计，重新排列列和行的顺序，将空单元格设置为显示

0

，隐藏展开/折叠按钮，重复所有项目标签集

*

，并添加边框

为了显示

0

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

---

---

*

在Excel 2007中不可用。要为早于Excel 2010的版本重复项目标签，标准做法是复制PT并粘贴特殊值，然后通过选择Go To Special空格来填充空格，然后

=

，Up，Ctrl+Enter。

是否尝试过透视表，或者如果有这么多记录，请启用透视（Excel 2010或更高版本）？我用于计算此数据的计算机是Excel 2007:（您的图片仅显示3个描述性列的唯一3组。始终是这样（对于所有行），或者您是否使用另一个值获得重复，然后对值进行求和。请添加更多详细信息。它具有另一个数据值（超过3个）但我不想总结这些value@pnuts当前位置pt似乎工作正常，但您能否解释更多关于您在上一部分提到的必须添加的行的信息。哇！我刚刚注意到您在参考链接之外发布了一个图像。我的答案基于参考链接，因此我必须立即更新您的图像。我可以通过h PT，但我仍然希望看到您的代码：）

'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