The given code does what you want. I did not expect it to be this long, sorry for that. But I think this is quite efficient. Sorry for no comments, but I accidentally spent more time on it that I expected. So, for you this might be difficult to understand the code. Anyways, questions are welcome.
Essentially, you are asked to select the 1st table, then the 2nd (no matter in which worksheet). Then the code traces the x
values from a column in the first table and writes names which has x
in that column into a thing called "dictionary". Then it's time for the 2nd table - if there is an x
next to some name, the value in the dictionary of that name is changed to 1
. Then, all the names which have the value of 1
in the dictionary are put to the str
string, and this string is outputted to the results array Array3
. This process repeats for every column in both input tables. Finally, results array is outputed to the newly created worksheet.
Alt + F11 opens the VBE. Insert > Module inserts a new module. The code should pe pasted to this module. When you have pasted the code, you can close the VBE window. Alt + F8 opens macros list.
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