In 1 word: AWESOME!
It worked like a charm. I tried the second one and it did what it had to, smoothly and quickly.
Thanks a lot for your support!!

Quote Originally Posted by p45cal View Post
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