Вот решение VBA. Установите рабочий массив с одной строкой для каждого отдельного члена, один столбец для каждого отдельного города и заполните 1, где совпадают элемент и город. Затем перенести в выходной массив, где для пар столбцов в рабочем массиве установлено значение 1:
Option Explicit
Sub MultResponse()
Dim LastRow, LastColumn As Long
Dim sht1, sht2 As Worksheet
Dim workArray() As Integer
Dim cityDict As New Scripting.Dictionary
Dim memberDict As New Scripting.Dictionary
Dim city, member As String
Dim item As Integer
Dim i, j As Long
Dim memberNo As Long
Dim cityNo As Integer
Dim outputArray() As Integer
Dim outrow, outcol, rowTotal As Integer
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
' Make list of distinct cities
j = 0
For i = 2 To LastRow
city = sht1.Cells(i, 2)
If city <> "" And Not cityDict.Exists(city) Then
j = j + 1
cityDict.Add Key:=city, item:=j
End If
Next i
' Make list of distinct members
j = 0
For i = 2 To LastRow
member = sht1.Cells(i, 1)
If member <> "" And Not memberDict.Exists(member) Then
j = j + 1
memberDict.Add Key:=member, item:=j
End If
Next i
' Set up and fill array with one row for each distinct member, one column for each distinct city
ReDim workArray(1 To memberDict.Count, 0 To cityDict.Count)
For i = 2 To LastRow
member = sht1.Cells(i, 1)
city = sht1.Cells(i, 2)
If city <> "" And member <> "" Then
memberNo = memberDict(member)
cityNo = cityDict(city)
workArray(memberNo, cityNo) = 1
End If
Next i
' Fill output array where pairs of columns in work array are set to 1
' outputArray(0,0) is used for members with missing city
ReDim outputArray(0 To cityDict.Count, 0 To cityDict.Count)
'First do ones with no affiliation
For i = 1 To memberDict.Count
rowTotal = 0
For j = 1 To cityDict.Count
rowTotal = rowTotal + workArray(i, j)
Next j
If rowTotal = 0 Then outputArray(0, 0) = outputArray(0, 0) + 1
Next i
' Then do ones with affiliation
For outrow = 1 To cityDict.Count
For outcol = 1 To cityDict.Count
For i = 1 To memberDict.Count
If workArray(i, outrow) = 1 And workArray(i, outcol) = 1 _
Then outputArray(outrow, outcol) = outputArray(outrow, outcol) + 1
Next i
Next outcol
Next outrow
' Transfer output array into sheet
For i = 0 To cityDict.Count
For j = 0 To cityDict.Count
sht2.Cells(i + 2, j + 2) = outputArray(i, j)
Next j
Next i
'Insert row and column headers
sht2.Cells(1, 2) = "N/C"
sht2.Cells(2, 1) = "N/C"
For i = 0 To cityDict.Count - 1
sht2.Cells(i + 3, 1) = cityDict.Keys(i)
Next i
For j = 0 To cityDict.Count - 1
sht2.Cells(1, j + 3) = cityDict.Keys(j)
Next j
End Sub
Данные испытаний
![enter image description here](https://i.stack.imgur.com/phx6H.png)
Результаты
![enter image description here](https://i.stack.imgur.com/MtEDQ.png)