How to do this? Thanks

[Paul]

I have an Excel workbook with the contact information in it, I need to
re-arrange it in orfder to to do some data search. The layout of the data is
in a single column as follow:

Name1 (font:Arial size:10 and Bold)
Address1 (font:Times New Roman size:10 Not Bold)
Address1.1 (font:Times New Roman size:10 Not Bold)
City1 (font:Times New Roman size:10 Not Bold)
Name2 (font:Arial size:10 and Bold)
Address2 (font:Times New Roman size:10 Not Bold)
Address2.2 (font:Times New Roman size:10 Not Bold)
City2 (font:Times New Roman size:10 Not Bold)
..
..
..
and so on

The only trick is for some of the contact it does not have the second line
of the address (i.e. Address1.1) and the contact information is shown as
follow:

Name1 (font:Arial size:10 and Bold)
Address1 (font:Times New Roman size:10 Not Bold)
City1 (font:Times New Roman size:10 Not Bold)
Name2 (font:Arial size:10 and Bold)
Address2 (font:Times New Roman size:10 Not Bold)
Address2.2 (font:Times New Roman size:10 Not Bold)
City2 (font:Times New Roman size:10 Not Bold)

I need to put the "AddressX" and "AddressX.X" and "CityX" into a column and
it will take me forever if iI have to copy and paste it one by one. Is there
a way I can use the vba code to achieve this? Thanks.

 

[Paul]

Also the "NameX" can be appeared twice for a single contact as follow:

 

[Tom Ogilvy]

Sub HIJ()
Dim rng As Range, rng1 As Range
Dim cell As Range, rng3 as Range
Dim ar As Range
Columns("B:F").ClearContents
Set rng3 = Cells(Rows.Count, 1).End(xlUp)(2)
rng3.Value = "Dummy"
rng3.Font.Bold = True

Set rng1 = Range(Range("A1"), rng3)
For Each cell In rng1
If cell.Font.Bold = False Then
cell.Resize(1, 2).Insert shift:=xlToRight
End If
Next
Set rng = rng1.SpecialCells(xlConstants)
For Each ar In rng.Areas
If ar.Count > 1 Then
ar(2).Insert shift:=xlToRight
Else
ar.Offset(0, 1).Formula = "=na()"
End If
If ar(1).Row > 1 Then
ar(0, 1).Resize(1, 2).Insert shift:=xlToRight
End If
Next

Set rng = rng1.Offset(0, 2).SpecialCells(xlConstants)
rng.Select
For Each ar In rng.Areas
If ar.Count > 1 Then
ar(2).Insert shift:=xlToRight
Else
ar.Offset(0, 1).Formula = "=na()"
End If
Next
rng3.EntireRow.Delete
Columns("A:F").SpecialCells(xlBlanks).Delete _
shift:=xlShiftUp
Columns("A:F").SpecialCells(xlFormulas, _
xlErrors).ClearContents
End Sub

--
Regards,
Tom Ogilvy

 

[Guest]

Nice to learn
Columns("A:F").SpecialCells(xlBlanks).Delete shift:=xlShiftUp

Also saw twice
Cells(Rows.Count, 1).End(xlUp)(2)

For exercise, we tried this.
There are extra blank lines at the end, probably not worth programming steps
to eliminate

Sub t()
For i = 1 To Cells(65536, 1).End(xlUp).Row
If Range("A" & i + 1).Font.Bold = True Then
Range("A" & i + 1).Cut Range("b" & i)
Range("A" & i + 2).Cut Range("c" & i)
Range("A" & i + 3).Cut Range("d" & i)
Range("A" & i + 4).Cut Range("e" & i)
i = i + 4
End If

If Range("A" & i + 1).Font.Bold = False Then
Range("A" & i + 1).Cut Range("c" & i)
Range("A" & i + 2).Cut Range("d" & i)
Range("A" & i + 3).Cut Range("e" & i)
i = i + 3
End If

Next i

For i = i To 1 Step -1
If IsEmpty(Range("A" & i)) Then Rows(i).Delete
Next i

End Sub

Regards

 

[Tom Ogilvy]

Didn't seem to cover all the contingencies for me, but maybe we understand
the problem differently.

 

[Paul]

Hi Tom:

It works and it does exactly what I want.

Thank you.

Paul

 

[Paul]

Hi Tom:

I'm really appreciated for what you have provided to my problem so far. I
did come across a condition that I am not sure if you can give me further
advice. The condition is the "Name" for each of the contact could have
multiple "Names" on it i.e. more than 2 as I posted incorrectly on the
newsgroup yesterday. Is there a way to create additional column depends on
the number of the "Name" appears on each of the contact? Many thanks.

 

[a54321]

test

 

[a54321]

test

 

[Tom Ogilvy]

Try this:

Sub HIJ()
Dim rng As Range, rng1 As Range
Dim cell As Range, rng3 As Range
Dim ar As Range, maxcnt As Long
Dim k As Long
Columns("B:F").ClearContents
Set rng3 = Cells(Rows.Count, 1).End(xlUp)(2)
rng3.Value = "Dummy"
rng3.Font.Bold = True

Set rng1 = Range(Range("A1"), rng3)
For Each cell In rng1
If cell.Font.Bold = False Then
cell.Resize(1, 1).Insert shift:=xlToRight
End If
Next
maxcnt = 0
Set rng = rng1.SpecialCells(xlConstants)
For Each ar In rng.Areas
If ar.Count > maxcnt Then
maxcnt = ar.Count
End If
Next
Columns(2).Resize(, maxcnt - 1).Insert
For Each ar In rng.Areas
If ar.Count > 1 Then
For k = 2 To ar.Count
ar(k).Resize(1, k - 1).Insert shift:=xlToRight
Next
End If
If ar.Count < maxcnt Then
ar(1).Offset(0, ar.Count).Resize(1, maxcnt - ar.Count) _
.Formula = "=na()"
End If
' ar(1).Offset(0, 1).Resize(1, maxcnt - 1).Formula = _
"=na()"

If ar(1).Row > 1 Then
ar(1).Offset(-1, maxcnt).Resize(1, 2).Insert _
shift:=xlToRight
End If
Next
Set rng = rng1.Offset(0, maxcnt).SpecialCells(xlConstants)
rng.Select
For Each ar In rng.Areas
If ar.Count > 1 Then
ar(2).Insert shift:=xlToRight
Else
ar.Offset(0, 1).Formula = "=na()"
End If
Next
rng3.EntireRow.Delete
Columns("A:M").SpecialCells(xlBlanks).Delete _
shift:=xlShiftUp
Columns("A:M").SpecialCells(xlFormulas, _
xlErrors).ClearContents
End Sub