Sub ReTable()
Dim arr(), newArr()
Dim dic As Object
Dim I&, N&
Dim iKey, iTmp
With Worksheets("Лист1")
  arr = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
  If Len(arr(I, 1)) > 0 Then
    iKey = arr(I, 1)
    If dic.Exists(iKey) Then
      iTmp = dic(iKey)
      ReDim Preserve iTmp(1 To UBound(iTmp) + 2)
      For N = 1 To 2
        J = IIf(N = 1, 1, 0)
        iTmp(UBound(iTmp) - J) = arr(I, N + 1)
      Next
      dic(iKey) = iTmp
    Else
      ReDim iTmp(1 To 2)
      For N = 2 To 3
        iTmp(N - 1) = arr(I, N)
      Next
      dic.Add iKey, iTmp
    End If
  End If
Next
ReDim newArr(1 To dic.Count, 1 To 3): N = 0
For Each iKey In dic.Keys
  iTmp = dic(iKey)
  N = N + 1
  If UBound(iTmp) > UBound(newArr, 2) Then ReDim Preserve newArr(1 To dic.Count, 1 To UBound(iTmp) + 2)
  newArr(N, 1) = iKey
  newArr(N, UBound(newArr, 2)) = iKey
  For J = 1 To UBound(iTmp)
    newArr(N, J + 1) = iTmp(J)
    If J Mod 2 Then
      newArr(N, UBound(newArr, 2)) = newArr(N, UBound(newArr, 2)) & "-" & iTmp(J)
    Else
      newArr(N, UBound(newArr, 2)) = newArr(N, UBound(newArr, 2)) & "(" & iTmp(J) & ")"
    End If
  Next
Next
Worksheets("Лист1").Range("G12").Resize(N, UBound(newArr, 2)) = newArr
End Sub

Sub OneBlock()
Dim iTbl As ListObject
Dim iCl As Range
Dim arr(), arrOne()
Dim dic As Object
Dim iKey, iTmp
Dim I&, J&, N&
On Error Resume Next
Set iTbl = Worksheets("многоблочная").ListObjects("Таблица1")
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each iCl In iTbl.ListColumns(1).DataBodyRange
    If IsEmpty(iCl) Then
        arr = iCl.Offset(1).CurrentRegion.Value
        For J = LBound(arr, 2) To UBound(arr, 2) Step 4
          For I = LBound(arr, 1) To UBound(arr, 1)
            If Not IsEmpty(arr(I, J)) Then
              iKey = arr(I, J)
              If dic.Exists(iKey) Then
                iTmp = dic(iKey)
                ReDim Preserve iTmp(1 To 4, 1 To UBound(iTmp, 2) + 1)
                For N = 0 To 3
                  iTmp(N + 1, UBound(iTmp, 2)) = arr(I, J + N)
                Next
                dic(iKey) = iTmp
              Else
                ReDim iTmp(1 To 4, 1 To 1)
                For N = 0 To 3
                  iTmp(N + 1, 1) = arr(I, J + N)
                Next
                dic.Add iKey, iTmp
              End If
            End If
          Next
        Next
    End If
Next
arr = iTbl.DataBodyRange.Value
ReDim arrOne(1 To Int(UBound(arr, 1) * (UBound(arr, 2) / 4)), 1 To 4): N = 0
For Each iKey In dic.Keys
    iTmp = dic(iKey)
    For I = LBound(iTmp, 2) To UBound(iTmp, 2)
        N = N + 1
        For J = 1 To 4
            arrOne(N, J) = iTmp(J, I)
        Next
    Next
Next
With Worksheets("одноблочная")
    .Range("F2").Resize(N, 4) = arrOne
    .Activate
End With
Application.ScreenUpdating = True
End Sub