code needed, please

[jvoortman]

I have a list I need to do some arranging in. Column A
(moving down one after another i.e A1, A2, etc) first has
the company name, then under it is the street address,
then under that is the city. It now repeats with new
information (every 3 lines are the same and there are no
spaces between the companies although in the end I would
like there to be 1 space). Now comes the tricky part. In
column B cell number 1 is the contact information for the
company in cells A1,A2,A3 and I would like that to appear
directly below the companies, and in column c we have the
phone numbers which would be ideal directly below the
contact name. Then 1 blank space and start all over
running down column a.
this link shows you the sample
http://legionprodarts.homestead.com/excelhelp.html
end result would read like this

A & B Courier
31 Alexander Rd.
Newmarket, L3Y 3J2
Mr. Dean Smalley
Phone905) 853-4444
Fax905) 853-5565

A & J Auto & Brake Shop
1175 Stellar Dr. Unit 4
Newmarket, L3Y 7B8
Mr. James Goldie
Phone905) 836-5773
Fax:

A-D Engineering Group Ltd.
130 Davis Dr., Ste. 202
Newmarket, L3Y 2N1
Mr. David Lehman
Phone905) 898-3514
Fax905) 898-1998

thanks in advance for any help.......

 

[Dave Peterson]

I think I'd just loop through the rows and look for the 3rd row of the
group--then copy that adjacent stuff over, too.

Option Explicit
Sub testme01()

Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Dim curWks As Worksheet
Dim newWks As Worksheet

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

oRow = 0
For iRow = FirstRow To LastRow
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells(iRow, 1).Value
If iRow Mod 3 = 0 Then
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells(iRow - 2, 2).Value
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells(iRow - 2, 3).Value
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells(iRow - 1, 3).Value
oRow = oRow + 1
End If
Next iRow
End With

newWks.UsedRange.Columns.AutoFit

End Sub

But this looks a lot like mailing labels. If it is, I think you'd be better off
having one row per record. If you like this idea, then run this against the new
sheet (or a copy of the new sheet). (It does delete stuff!)


Option Explicit
Sub testme02()

Dim curWks As Worksheet
Dim myBigRng As Range
Dim myLittleRng As Range

Set curWks = ActiveSheet

With curWks
Set myBigRng = Nothing
On Error Resume Next
Set myBigRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp)) _
.Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If myBigRng Is Nothing Then
MsgBox "something is terribly wrong!"
Exit Sub
End If

For Each myLittleRng In myBigRng.Areas
myLittleRng.Copy
myLittleRng(1, 1).Offset(0, 1).PasteSpecial Transpose:=True
Next myLittleRng

.Range("a:a").Delete
.Range("a:a").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

.UsedRange.Columns.AutoFit

End With

End Sub

Now you can use filters/sorts and all that nice stuff. And if you want to
create mailing labels, you could use your nice flat excel file as the datasource
within word.

And if you use mailmerge as much as I do (almost never???), you can read more
about it at:

http://www.mvps.org/dmcritchie/excel/mailmerg.htm
http://www.mvps.org/word/FAQs/MailMerge/index.html

The first is from David McRitchie and the second is by Beth Melton and Dave
Rado.

 

[jvoortman]

thanks Dvae, that worked great. You were right, it is for
mailing labels, but until I have it in the requested
format, i can't use code I got here earlier to set it up
as I would like it. THANKS EVERYONE!!!!!!!

-----Original Message-----
I think I'd just loop through the rows and look for the 3rd row of the
group--then copy that adjacent stuff over, too.

Option Explicit
Sub testme01()

Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long

Dim curWks As Worksheet
Dim newWks As Worksheet

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

oRow = 0
For iRow = FirstRow To LastRow
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells(iRow, 1).Value
If iRow Mod 3 = 0 Then
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells (iRow - 2, 2).Value
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells (iRow - 2, 3).Value
oRow = oRow + 1
newWks.Cells(oRow, 1).Value = .Cells (iRow - 1, 3).Value
oRow = oRow + 1
End If
Next iRow
End With

newWks.UsedRange.Columns.AutoFit

End Sub

But this looks a lot like mailing labels. If it is, I think you'd be better off
having one row per record. If you like this idea, then run this against the new
sheet (or a copy of the new sheet). (It does delete stuff!)


Option Explicit
Sub testme02()

Dim curWks As Worksheet
Dim myBigRng As Range
Dim myLittleRng As Range

Set curWks = ActiveSheet

With curWks
Set myBigRng = Nothing
On Error Resume Next
Set myBigRng = .Range("a1", .Cells

(.Rows.Count, "A").End(xlUp)) _