Sub bb()
Dim v(), di As Object, i&, j&, m&, x, y
v = Range("A4", Cells(Rows.Count, "C").End(xlUp)).Value
Set di = CreateObject("scripting.dictionary")
On Error GoTo 1
For i = 1 To UBound(v)
    di(v(i, 1))(0).Item(v(i, 2)) = Empty
    di(v(i, 1))(1).Item(v(i, 3)) = Empty
Next
On Error GoTo 0
Erase v
Worksheets.Add
i = 0
For Each x In di.keys
  i = i + 1
  j = 1
  Cells(i, j) = x
  For Each y In di(x)(0).keys
    j = j + 1
    Cells(i, j) = y
  Next
  For Each y In di(x)(1).keys
    j = j + 1
    Cells(i, j) = y
  Next
Next


Exit Sub

1 If Err = 13 Then 'Type mismatch
    di(v(i, 1)) = Array(CreateObject("scripting.dictionary"), CreateObject("scripting.dictionary"))
    Resume
  Else: Stop
  End If
End Sub

Sub Trans()
    Dim rngHor As Range
    Dim rngVer As Range
    Dim rngOut As Range
    Dim counter As Long
    Dim lngRow As Long
    Dim cell As Range
 
    Set rngHor = Application.InputBox("Enter Data range", Type:=8)
    Set rngVer = Application.InputBox("Enter Vertical range", Type:=8)
    Set rngOut = Application.InputBox("Enter Output range", Type:=8)
 
    For Each cell In rngVer
        DoEvents
        rngOut(counter + 1, 1).Resize(rngHor.Columns.Count, 1).Value2 = cell
        rngOut(counter + 1, 2).Resize(rngHor.Columns.Count, 1).Value2 = WorksheetFunction.Transpose(rngHor.Rows(lngRow + 1))
        lngRow = lngRow + 1
        counter = counter + rngHor.Columns.Count
    Next
    
Const lCol As Long = 2 'Номер слобца,где ищем пустые ячейки
Const lFirstRow As Long = 1 'Номер строки с которой начинаем отчёт
Dim li As Long, lLastRow As Long, lCalc As Long
With Application
'Для ускорения выполнения Отключаем обновление экрна и пересчет формул
.ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual 'идем циклом по всем ячейкам столбца lCol
For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1
'Если ячейка пустая - удаляем строку.
If Cells(li, lCol) = "" Then Rows(li).Delete
Next li
'возвращаем обновление экрна и пересчет формул
.ScreenUpdating = 1: .Calculation = lCalc
End With
End Sub

Sub Trans() 
Dim rngHor As Range 
Dim rngVer As Range 
Dim rngOut As Range 
Dim counter As Long 
Dim lngRow As Long 
Dim cell As Range 

Set rngHor = Application.InputBox("Enter Data range", Type:=8) 
Set rngVer = Application.InputBox("Enter Vertical range", Type:=8) 
Set rngOut = Application.InputBox("Enter Output range", Type:=8) 

For Each cell In rngVer 
DoEvents 
rngOut(counter + 1, 1).Resize(rngHor.Columns.Count, 1).Value2 = cell 
rngOut(counter + 1, 2).Resize(rngHor.Columns.Count, 1).Value2 = WorksheetFunction.Transpose(rngHor.Rows(lngRow + 1)) 
lngRow = lngRow + 1 
counter = counter + rngHor.Columns.Count 
Next 

Const lCol As Long = 2 'Номер слобца,где ищем пустые ячейки 
Const lFirstRow As Long = 1 'Номер строки с которой начинаем отчёт 
Dim li As Long, lLastRow As Long, lCalc As Long 
With Application 
'Для ускорения выполнения Отключаем обновление экрна и пересчет формул 
.ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual 'идем циклом по всем ячейкам столбца lCol 
For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1 
'Если ячейка пустая - удаляем строку. 
If Cells(li, lCol) = "" Then Rows(li).Delete 
Next li 
'возвращаем обновление экрна и пересчет формул 
.ScreenUpdating = 1: .Calculation = lCalc 
End With 
End Sub

Sub Слеить_сцепить()
  For r = ActiveCell.Row To ActiveCell.End(xlDown).Row
    Cells(r, 1) = "(" & Cells(r, 1) & "," & Cells(r, 2) & ")"
    Range(Cells(r, 2), Cells(r, 2)).ClearContents
    Range(Cells(r, 1), Cells(r, 2)).Merge
  Next
End Sub