contact data in column to rows

[Mike]

Hello, I have a fairly huge excel file in this format:

1 Bob Smith
2 123 fair lane
3 toledo, oh 12345-1234
4 Phone: (123) 456-4567
5 Fax: (123) 456-2345
6 (e-mail address removed)
7
8 Bob Smith
9 123 fair lane
10 toledo, oh 12345-1234
11 Phone: (123) 456-4567
12
13 Bob Smith
14 VP of nothing
15 123 fair lane
16 toledo, oh 12345-1234
17 Phone: (123) 456-4567

and on and on.

what I need is a macro that:
starts at A1
selects the range A1:A6 (whatever it's size)
copies it
moves to B1
paste:transpose
deletes rows 2-7

and runs again...

I'm stumped I've seen some offset stuff, but the selection fo the
range baffles me.

some data is only 4 rows some is 12 rows. I can handle moving the
data into the appropriate columns after this step is done, unless
someone has an idea of putting phone and fax into appropriate columns
(because they always begin with phone or fax), or @ symbol for e-mail
or , & - for city state zip.

any help would be appreciated.

 

[Peter Atherton]

Mike

This does not work as well as I would like but is
reasonable.

Make sure that there is a blank row above the addresses.
Select them and run the code.

Sub Transpose()
Dim c
Dim i As Integer, j As Integer, nr As Integer, count As
Integer
Dim rng As Range

'place values on rows
Set rng = Selection
nr = rng.Rows.count

For Each c In rng
c.Select
If IsEmpty(c) Then
j = 0: i = 0
ElseIf IsEmpty(c) = False Then
j = j + 1: i = i - 1
ActiveCell.Offset(i, j).Value = c.Value
End If
Next c
'delete column A
Columns("A:A").Select
Selection.Delete shift:=xlToLeft
'Get rid or redundant rows
For i = 2 To nr
Cells(i, 1).Select
If IsEmpty(ActiveCell) Then
Selection.EntireRow.Delete
i = i - 1
count = count + 1
If count = 10 Then
Exit Sub
End If
End If
Next i

End Sub

regards
Peter

 

[Cecilkumara Fernando]

Mike,
copy a part of the data to a new worksheet
and run this macro to see the outcome
HTH
Cecil

Sub Macro1()
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR + 1
If Range("A" & i).Value = 0 Then
y = Range("A" & i).Row - x
x = Range("A" & i).Row
End If
If z < y Then z = y
Next i
x = LR
For i = LR To 1 Step -1
If Range("A" & i).Value = 0 Then
y = x - Range("A" & i).Row
b = b + 1
If b > 1 Then
For j = y To z
Range("A" & x).EntireRow.Insert (xlDown)
Next j
End If
x = Range("A" & i).Row
End If
Next i
y = x
For j = y To z
Range("A" & x).EntireRow.Insert (xlDown)
Next j
z = z + 1
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:A" & LR).Select
Selection.Find(What:="@", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
x = ActiveCell.Row
Do Until y = x
Selection.FindNext(After:=ActiveCell).Activate
y = ActiveCell.Row
Cells((Int(ActiveCell.Row / z)) * z + 1, z).Value _
= ActiveCell.Value
ActiveCell.Clear
Loop
Range("A1:A" & LR).Select
Selection.Find(What:="Fax", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
x = ActiveCell.Row
Do Until y = x
Selection.FindNext(After:=ActiveCell).Activate
y = ActiveCell.Row
Cells((Int(ActiveCell.Row / z)) * z + 1, z - 1).Value _
= ActiveCell.Value
ActiveCell.Clear
Loop
Range("A1:A" & LR).Select
Selection.Find(What:="Phone", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
x = ActiveCell.Row
Do Until y = x
Selection.FindNext(After:=ActiveCell).Activate
y = ActiveCell.Row
Cells((Int(ActiveCell.Row / z)) * z + 1, z - 2).Value _
= ActiveCell.Value
ActiveCell.Clear
Loop
Range("A1:A" & LR).Select
Selection.Find(What:="-", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
x = ActiveCell.Row
Do Until y = x
Selection.FindNext(After:=ActiveCell).Activate
y = ActiveCell.Row
Cells((Int(ActiveCell.Row / z)) * z + 1, z - 3).Value _
= ActiveCell.Value
ActiveCell.Clear
Loop
For i = 0 To Int(LR / z)
x = i * z + 1
Range(Cells(x + 1, 1), Cells(x + (z - 5), 1)).Select
Selection.Copy
Range("B" & x).Select
Selection.PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Range(Cells(x + 1, 1), Cells(x + (z - 5), 1)).Clear
Next i
Range("A1:A" & LR).Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[peter Atherton`]

Mike

I tested my previous effort with more data and it was
rubish. This is the amended macro tested on 100 lines of
data.

I suggest that you enter Headings (Customer, Address etc)
in columns B to F two rows above the the first record.

Select the racords and run the macro.

I got an error running Cecilkumaara's programm.

Regards
Peter

 

[Cecilkumara Fernando]

Peter,
what is the error you get while running my code
with the following data set it worked as expected
regards
Cecil

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567

Bob Smith
VP of nothing
TestRow
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567

Bob Smith
VP of nothing
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567

Bob Smith
VP of nothing
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)

Bob Smith
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567

Bob Smith
VP of nothing
123 fair lane
toledo, oh 12345-1234
Phone: (123) 456-4567
Fax: (123) 456-2345
(e-mail address removed)