ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   How to do this? Thanks (https://www.excelbanter.com/excel-programming/354227-how-do-thanks.html)

Paul
How to do this? Thanks
 
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
How to do this? Thanks
 
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.

Tom Ogilvy
How to do this? Thanks
 
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.

PY & Associates[_4_]
How to do this? Thanks
 
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" wrote:

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.

Tom Ogilvy
How to do this? Thanks
 
Didn't seem to cover all the contingencies for me, but maybe we understand
the problem differently.

--
Regards,
Tom Ogilvy


"PY & Associates" wrote in message
...
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" wrote:

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.

Paul
How to do this? Thanks
 
Hi Tom:

It works and it does exactly what I want.

Thank you.

Paul
"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.

Paul
How to do this? Thanks
 
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.

[email protected]
How to do this? Thanks
 
test

[email protected]
How to do this? Thanks
 
test

Tom Ogilvy
How to do this? Thanks
 
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.


All times are GMT +1. The time now is 04:08 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com