Sub Macros()
    Application.ScreenUpdating = False
    Dim Arr1 As Variant, Arr2 As Variant, Arr3() As Variant
    Dim i As Long, j As Long, n As Long
    Dim sRow As Long, sCol As Long, fRow As Long, fCol As Long
    Set zc = Cells.Find("*")
    sRow = zc.Row 'номер строки первой заполненной ячейки
    sCol = zc.Column 'номер столбца первой заполненной ячейки
    fRow = Range(Left(zc.Address(0, 0), 1) & Rows.Count).End(xlUp).Row 'номер строки последней заполненной ячейки
    fCol = Range(zc.Address).End(xlToRight).Column 'номер столбца последней заполненной ячейки

    For i = sCol To fCol - 1 'цикл для первого столбца в сравнении
        For j = i + 1 To fCol 'цикл для второго столбца в сравнении
            Arr1 = Range(Cells(sRow + 1, i), Cells(fRow, i)) 'массив первого столбца в сравнении
            Arr2 = Range(Cells(sRow + 1, j), Cells(fRow, j)) 'массив второго столбца в сравнении
            For n = 1 To UBound(Arr1) 'цикл по массивам
                If Arr1(n, 1) = Arr2(n, 1) And Arr1(n, 1) <> Empty Then Exit For 'сравнение значений массивов
                ReDim Preserve Arr3(1 To 1, 1 To n) ' создаем массив для объединения
                On Error Resume Next 'пропускаем ошибку, если пустое значение
                Arr3(1, n) = 1 * (Arr1(n, 1) & Arr2(n, 1)) 'объединяем массивы
                If n = UBound(Arr1) Then GoTo finish 'если проверили весь массив, то пара столбцов подобрана. Заканчиваем.
            Next n
        Next j
    Next i
finish:
    Cells(1, fCol + 2) = Cells(1, i) & " и " & Cells(1, j) 'вывод номеров подобранных столбцов
    Cells(2, fCol + 2).Resize(n, 1) = Application.Transpose(Arr3) 'вывод объединенного массива
    Application.ScreenUpdating = True
End Sub