VBA to convert person-to-event into person-person

Try this:-
It a bit basic at the moment , need cleaning up( putting in an array).
The code first fills Column "D" on sheet "current format", then uses this data to fill sheet "desired format" , Column "D" on.
See if its what you want !!!!

Sub MG07May27
Dim Rng As Range, Dn As Range, n As Long
Dim Dic1 As Object
Dim Dic2 As Object
Dim oMax As Long
Dim Q
With Sheets("current format")
Set Rng = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
End With
Set Dic1 = CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
Set Dic2 = CreateObject("scripting.dictionary")
Dic2.CompareMode = vbTextCompare

For Each Dn In Rng
    If Not Dic1.exists(Dn.Value) Then
        n = n + 1
        Cells(n, "D") = Dn
        Cells(n, "E") = Dn.Offset(, -1)
        Dic1.Add Dn.Value, Array(n, 5)
    Else
        Q = Dic1.Item(Dn.Value)
        Q(1) = Q(1) + 1
        Cells(Q(0), Q(1)) = Dn.Offset(, -1)
        oMax = Application.Max(oMax, Q(1))
        Dic1.Item(Dn.Value) = Q

    End If
Next

Dic1.RemoveAll
Set Rng = Range("E1").Resize(n, oMax - 4)
For Each Dn In Rng
    If Not Dn.Value = vbNullString Then
        If Not Dic1.exists(Dn.Value) Then
            Dic1.Add Dn.Value, Dn
        Else
            Set Dic1.Item(Dn.Value) = Union(Dic1.Item(Dn.Value), Dn)
        End If
    End If
Next Dn

Dim k
Dim p As Range
For Each k In Dic1.keys

For Each p In Dic1.Item(k)
    If Not Dic2.exists(k) Then
        Set Dic2(k) = CreateObject("Scripting.Dictionary")
    End If
For Each Dn In Range("E" & p.Row).Resize(, oMax - 4)
   If Not Dn = k And Not Dn = vbNullString Then
        If Not Dic2(k).exists(Dn.Value) Then
                Dic2(k).Add (Dn.Value), 1
        Else
                Dic2(k).Item(Dn.Value) = Dic2(k).Item(Dn.Value) + 1
        End If

    End If
Next Dn
Next p
Next k

Dim KK
Dim c As Long
Dim pp As Variant
For Each KK In Dic2.keys
    For Each pp In Dic2.Item(KK)
        With Sheets("desired format")
            c = c + 1
            .Cells(c, "D") = KK
            .Cells(c, "E") = pp
            .Cells(c, "F") = Dic2(KK).Item(pp)
        End With
    Next pp
Next KK
MsgBox "run"
End Sub

Regards Mick

I think this will be close to what you want. Be aware that since the same names appear in column A as in column B in the output sheet, there will be duplicate results. For example, if Person A and Person X both attended Event 1, you would get

Person A | Person X | 1
Person X | Person A | 1

I didn't know if that was ok or not, so I left it.

Sub PersonEvents()
Dim PerRw As Long, EvRw As Long, OutRw As Long, OutSheet As Worksheet
    Sheets("current format").Select
    Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order1:=xlAscending, Header:=xlGuess

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("event sheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ActiveSheet.Copy after:=Sheets(ActiveSheet.Name)
    ActiveSheet.Name = "event sheet"
    Range("A1").Sort key1:=Range("B1"), order1:=xlAscending, key2:=Range("A1"), order1:=xlAscending, Header:=xlGuess

    Set OutSheet = Sheets("desired format")
    With OutSheet
        .Cells.ClearContents
        .Range("A1").Value = "Person 1"
        .Range("B1").Value = "Person 2"
    End With

    PerRw = 2
    OutRw = 2
    With Sheets("current format")
        Do Until .Cells(PerRw, 1).Value = ""
            EvRw = Cells.Find(.Cells(PerRw, 2).Value, , , xlWhole).Row
            Do Until Cells(EvRw, 2).Value <> .Cells(PerRw, 2).Value
                If Cells(EvRw, 1).Value <> .Cells(PerRw, 1).Value Then
                    OutSheet.Cells(OutRw, 1).Value = .Cells(PerRw, 1).Value
                    OutSheet.Cells(OutRw, 2).Value = Cells(EvRw, 1).Value
                    OutRw = OutRw + 1
                End If
                EvRw = EvRw + 1
            Loop
            PerRw = PerRw + 1
        Loop
    End With

    OutSheet.Select
    Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order1:=xlAscending, Header:=xlGuess
    Range("C1").Value = "Shared Events"
    OutRw = 2
    Do Until Cells(OutRw, 1).Value = ""
        PerRw = OutRw
        Do Until Cells(OutRw, 1).Value & Cells(OutRw, 2).Value <> Cells(PerRw, 1).Value & Cells(PerRw, 2).Value
            Cells(OutRw, 3).Value = Cells(OutRw, 3).Value + 1
            PerRw = PerRw + 1
        Loop
        If PerRw - 1 > OutRw Then
            Rows(OutRw + 1 & ":" & PerRw - 1).Delete
        End If
        OutRw = OutRw + 1
    Loop
End Sub