Sub qq()
Dim arr(), i As Long, j As Long, n As Long
arr = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, 1)).Value
ReDim nArr(1 To (UBound(arr) - 1) * UBound(arr), 1) As String
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr)
        If i <> j Then
            n = n + 1
            nArr(n, 0) = arr(i, 1)
            nArr(n, 1) = arr(j, 1)
        End If
    Next j
Next i
Erase arr
Range(Cells(1, 2), Cells(n, 3)).Value = nArr
Erase nArr
End Sub