Данный код делает то, что вы хотите. Я не ожидал, что это будет так долго, извините за это. Но я думаю, что это довольно эффективно. Извините за отсутствие комментариев, но я случайно потратил на это больше времени, чем ожидал. Таким образом, для вас это может быть трудно понять код. В любом случае, вопросы приветствуются.
По сути, вас просят выбрать 1-ю таблицу, а затем 2-ю (независимо от того, в какой таблице). Затем код отслеживает значения x
из столбца в первой таблице и записывает имена, в которых есть x
в этом столбце, в вещь, называемую "словарь". Тогда пришло время для 2 - й таблицы - если есть 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