PDA

View Full Version : Break single row into multiple rows based on FORMAT



Jacopo
04-11-2017, 03:51 AM
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:

p45cal
04-11-2017, 06:51 AM
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

Jacopo
04-11-2017, 08:33 AM
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:


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