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


--
Regards,
Tom Ogilvy

"Paul" wrote in message
...
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.


"Tom Ogilvy" wrote in message
...
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




--
Regards,
Tom Ogilvy




"Paul" wrote in message
...
Also the "NameX" can be appeared twice for a single contact 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)
Name2.2 (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)


"Paul" wrote in message
...
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.