Sub Demo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Sht1LastRow As Long, Sht1ThisRow As Long, Sht1DataRow As Long
Dim Sht2 As Worksheet, Sht2ThisRow As Long, Sht2ThisCol As Long
With ActiveWorkbook
  Set Sht2 = .Sheets(2)
  Sht2ThisRow = Sht2.Cells.SpecialCells(xlCellTypeLastCell).Row
  With .Sheets(1)
    Sht1LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
    For Sht1ThisRow = 1 To Sht1LastRow
      If Trim(.Range("A" & Sht1ThisRow).Value) <> "" Then
        Sht2ThisRow = Sht2ThisRow + 1
        Sht2.Range("A" & Sht2ThisRow).Value = .Range("A" & Sht1ThisRow).Value
        If .Range("C" & Sht1ThisRow).Value <> "" Then
          Sht2.Range("B" & Sht2ThisRow).Value = .Range("C" & Sht1ThisRow).Value
        End If
        Sht2ThisCol = 3
        If .Range("B" & Sht1ThisRow).Value = "" Then Sht1ThisRow = Sht1ThisRow + 1
        For Sht1DataRow = Sht1ThisRow To Sht1LastRow
          If .Range("B" & Sht1DataRow).Value = "" Then
            Sht1ThisRow = Sht1DataRow
            Exit For
          End If
          Sht2.Cells(Sht2ThisRow, Sht2ThisCol).Value = .Range("B" & Sht1DataRow).Value
          Sht2ThisCol = Sht2ThisCol + 1
        Next Sht1DataRow
      End If
    Next Sht1ThisRow
  End With
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub