Try either of these, the second might run a bit faster. They work on whichever sheet is the active sheet.
Sub blah()
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
LastRw = Cells(Rows.Count, 1).End(xlUp).Row
Set FirstCell = Range("A1")
If Len(Trim(FirstCell.Value)) = 0 Then Set FirstCell = FirstCell.End(xlDown)
If FirstCell.Row >= LastRw Then Exit Sub 'nothing (or just 1 cell with something) in column A.
rw = LastRw
Do Until rw <= FirstCell.Row
myCount = 1
Do Until Cells(rw, 1).Font.Name = "Courier" And Cells(rw, 1).Font.Size = 40 And Cells(rw, 1).Font.Bold = True
With Cells(rw, 1).Resize(, myCount)
'.Select
.Copy Cells(rw - 1, 2)
.ClearContents
End With
myCount = myCount + 1
rw = rw - 1
Loop
rw = rw - 1
Loop
'optional line below to close up remaining spaces if you haven't anything you want to preserve elswhere on those rows:
Range(FirstCell, Cells(LastRw, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub blah2()
'Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
LastRw = Cells(Rows.Count, 1).End(xlUp).Row
Set FirstCell = Range("A1")
If Len(Trim(FirstCell.Value)) = 0 Then Set FirstCell = FirstCell.End(xlDown)
If FirstCell.Row >= LastRw Then Exit Sub 'nothing (or just 1 cell with something) in column A.
Count = 0: StartBlock = LastRw
For rw = LastRw To FirstCell.Row Step -1
With Cells(rw, 1)
If .Font.Name = "Courier" And .Font.Size = 40 And Cells(rw, 1).Font.Bold Then
If Count > 0 Then
Set bbb = Cells(StartBlock - Count + 1, 1).Resize(Count)
'bbb.Select
bbb.Copy
.Offset(, 1).PasteSpecial Transpose:=True
bbb.EntireRow.Delete
'bbb.ClearContents 'an alternative to the line above.
End If
StartBlock = rw - 1: Count = 0
Else
Count = Count + 1
End If
End With
Next rw
End Sub