=ИНДЕКС(З;ПОИСКПОЗ(RC[-1];П;);ПОИСКПОЗ(RC[-2];О;))

Sub Свести()
    CloseEmptyWb
    Dim arr As Variant
    arr = GetArr(ActiveSheet, 1, 3)
    If IsEmpty(arr) Then Exit Sub
    
    Dim mrr As Variant
    mrr = GetMultArr(arr)
    Erase arr
    
    OutPut mrr
End Sub

Private Sub OutPut(arr As Variant)
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        .Value = arr
    End With
    wb.Saved = True
End Sub

Private Function GetMultArr(arr As Variant) As Variant
    Dim mrr As Variant
    ReDim mrr(1 To UBound(arr, 1) * (UBound(arr, 1) - 1), 1 To 2)
    Dim yy As Long
    Dim uu As Long
    Dim oo As Long
    For yy = 1 To UBound(arr, 1)
        For uu = 1 To UBound(arr, 1)
            If yy <> uu Then
                oo = oo + 1
                mrr(oo, 1) = arr(yy, 1)
                mrr(oo, 2) = arr(uu, 1)
            End If
        Next
    Next
    GetMultArr = mrr
End Function

Private Function GetArr(sh As Worksheet, xColumn As Long, firstRow As Long)
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, xColumn).End(xlUp).Row
        Dim arr As Variant
        Select Case yy
        Case Is < firstRow
        Case firstRow
'            ReDim arr(1 To 1, 1 To 1)
'            arr(1, 1) = .Cells(yy, xColumn).Value
        Case Else
            arr = .Range(.Cells(firstRow, xColumn), .Cells(yy, xColumn))
        End Select
        GetArr = arr
    End With
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub