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

给定的代码可以满足您的需求。我没想到会这么长，对此感到抱歉。但是我认为这非常有效。抱歉，没有任何评论，但我无意间花了更多时间在我期望的位置上。因此，对于您来说，这可能很难理解代码。无论如何，欢迎提出问题。

本质上，要求您选择第一个表，然后选择第二个表（无论在哪个工作表中）。然后，代码x从第一个表中的列跟踪值，并将该列中包含的名称写入x称为“字典”的事物中。然后是第二张表的时间了-如果x某个名称旁边有一个名称，则该名称的词典中的值将更改为1。然后，将所有1在字典中具有值的名称放入str字符串中，并将此字符串输出到results数组中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