Sub tt()
    r0_ = 3
    c00_ = 1
    c01_ = 4
    nc_ = Cells(r0_ - 1, Columns.Count).End(1).Column - c01_ + 1
    nr_ = Cells(Rows.Count, c01_).End(3).Row - r0_ + 1
    ar = Cells(r0_, c01_).Resize(nr_, nc_)
    n_ = WorksheetFunction.CountA(Cells(r0_, c01_ + 1).Resize(nr_, nc_ - 1))
    ReDim ar1(1 To n_, 1 To 2)
    k_ = 1
    For i = 1 To nr_
        ar1(k_, 1) = ar(i, 1)
        For j = 2 To nc_
            If ar(i, j) <> "" Then
                ar1(k_, 2) = ar(i, j)
                k_ = k_ + 1
            Else
                Exit For
            End If
        Next j
'        k_ = k_ - 1
    Next i
    Cells(r0_, c00_).Resize(Rows.Count - r0_, 2).Clear
    Cells(r0_, c00_).Resize(n_, 2) = ar1
End Sub

Sub ReTable()
Dim i As Long
Dim iLastRow As Long
Dim Col As Integer
Dim stroka As Integer
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    stroka = 3
  For i = 3 To iLastRow
    Col = 4
      Cells(stroka, Col) = Cells(i, "A")
    Do
      Col = Col + 1
      Cells(stroka, Col) = Cells(i, "B")
      i = i + 1
    Loop While Cells(i, "A") = "" And i < iLastRow + 1
      stroka = stroka + 1
      i = i - 1
  Next
End Sub

Sub proba()
  Dim iCol&, iRow&, LastRow&, i&
  Dim shOut As Worksheet: Set shOut = ThisWorkbook.ActiveSheet
  Dim shIn As Worksheet:  Set shIn = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  
  LastRow = shOut.Cells(shOut.Rows.Count, 2).End(xlUp).Row
  iRow = 2  ' строка с которой начинаем заполнение
  For i = 3 To LastRow
    iCol = 1 'колонка с которой начинаем заполнение
    shIn.Cells(iRow, iCol) = shOut.Cells(i, 1)
    Do: iCol = iCol + 1
      shIn.Cells(iRow, iCol) = shOut.Cells(i, 2)
      i = i + 1
      If i > LastRow Then GoTo ExitSub
    Loop Until shOut.Cells(i, 1) <> ""
    i = i - 1
    iRow = iRow + 1
  Next

ExitSub:
    shIn.Cells.EntireColumn.AutoFit
End Sub