Break single row into multiple rows based on FORMAT

Dear all,
I'm quite new to VBA but really need a way to sort this out. Made a lot of googling but never found something to get through.
I have an excel sheet with a lot of information listed under the same column, where the entry title (the name of the person - NAME SURNAME) has a specific formatting, say Courier Bold 40.

The sheet is as follows (not all entries have all Subtitles):

A |
NAME SURNAME |
Subtitle 1 |
Subtitle 2 |
Subtitle 3 |
(Subtitle 4) |
|
NAME SURNAME |
Subtitle 1 |
Subtitle 2 |
Subtitle 3 |
(Subtitle 4)
....


What I am looking for is to create a spreadsheet where every A column contains NAME SURNAME, while all other information (subtitles) get reordered in the respective B, C, D, E, .... columns. Any idea?

A | | C | D | ....
NAME SURNAME | Subtitle 1 | Subtitle 2 | Subtitle 3 | ...


This is really a puzzle for me! :banghead:

Thanks a lot!!: pray2:

Try either of these, the second might run a bit faster. They work on whichever sheet is the active sheet.

Code:

---

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

---

Code:

---

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

---

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!! :clap:

Quote:

---

Originally Posted by p45cal

Try either of these, the second might run a bit faster. They work on whichever sheet is the active sheet.

Code:

---

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

---

Code:

---

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

---

---