☰

Excel：将两个列表转换为矩阵

tag-icon • tag-icon microsoft-excel worksheet-function spreadsheet
Excel：将两个列表转换为矩阵

我的工作簿中目前有两个列表

Name | System 1 | System 2 | System 3 |
John |    x     |    x     |          |
James|          |    x     |    x     |
Peter|          |    x     |          |


Name | Process A | Process B | Process C |
John |           |    x      |           |
James|     x     |           |     x     |
Peter|     x     |           |     x     |

有什么方法可以将这两个列表合并为如下所示的矩阵格式？

         |  Process A   |   Process B  |  Process C   |
System 1 |              |     John     |              |
System 2 | James, Peter |     John     | James, Peter |
System 3 |    James     |              |     James    |

谢谢。感谢你们提供的所有帮助。

答案1

给出的代码可以满足您的要求。我没想到它会这么长，对此我深表歉意。但我认为这是相当有效的。很抱歉没有评论，但我无意中花费了比预期更多的时间。因此，对于您来说，理解这段代码可能有些困难。无论如何，欢迎提问。

本质上，您需要选择第一个表，然后选择第二个表（无论在哪个工作表中）。然后，代码会跟踪x第一个表中某一列的值，并将x该列中包含 的名称写入一个称为“字典”的东西中。然后是第二个表的时间 - 如果x某个名称旁边有一个 ，则该名称在字典中的值将更改为1。然后，将字典中所有具有 值的名称1放入str字符串中，并将该字符串输出到结果数组Array3。对两个输入表中的每一列重复此过程。最后，将结果数组输出到新创建的工作表中。

Alt+F11打开 VBE。插入>模块插入新模块。代码应粘贴到此模块。粘贴代码后，您可以关闭 VBE 窗口。Alt+F8打开宏列表。

Sub Join_tables()
Dim ws As Worksheet
Dim Array1 As Variant
Dim Array2 As Variant
Dim Array3() As Variant
Dim dict As Object
Dim dicKey As Variant
Dim str As String
Dim j As Long, k As Long, i As Long 'counters
Array1 = Application.InputBox("Select the 1st table.", "Get List", Type:=64)
Array2 = Application.InputBox("Select the 2nd table.", "Get List", Type:=64)
ReDim Array3(1 To UBound(Array1, 2), 1 To UBound(Array2, 2))
Set dict = CreateObject("Scripting.Dictionary")

For j = 2 To UBound(Array3, 1)
    Array3(j, 1) = Array1(1, j)
    For k = 2 To UBound(Array3, 2)
        If Array3(1, k) = vbNullString Then Array3(1, k) = Array2(1, k)

        For i = 2 To UBound(Array1, 1)
            If Array1(i, j) = "x" Then
                On Error Resume Next
                dict.Add Array1(i, 1), 0
                On Error GoTo 0
                If Err.Number = 457 Then Err.Clear
            End If
        Next

        For i = 2 To UBound(Array2, 1)
            If Array2(i, k) = "x" Then
                If dict.exists(Array2(i, 1)) Then
                    dict.Item(Array2(i, 1)) = 1
                End If
            End If
        Next

        str = vbNullString
        For Each dicKey In dict.keys
            If dict.Item(dicKey) = 1 Then
                str = str & dicKey & ", "
            End If
        Next
        dict.RemoveAll
        If str <> vbNullString Then str = Left(str, Len(str) - 2)

        Array3(j, k) = str

    Next 'k
Next 'j

Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws.Range("A1").Resize(UBound(Array3, 1), UBound(Array3, 2)) = Array3

Set ws = Nothing
Set dict = Nothing
End Sub

相关内容