Reorganizing rows into groups

[loopkid1]

I've got a basic contact list in the following format:

| A | B | C | D | E | F
| G |
| LNAME | FNAME | ADDRESS | CITY | STATE | ZIP | PHONE |


and so on. Is there any way to pull the data from the rows and insert
it into a pre-formatted layout for each row? For example:

| A | B | C | D |
| *LName, FName* | | | *LName, FName* |
| *Address* | | | *Address* |
| *City, State Zip* | | | *City, State Zip* |
| *Phone* | | | *Phone* |

Basically, I want to convert it into a pdf file and have it easily
readable. If there's a better way to reach that end, I'm definately up
for learning it! Thanks!

Dave Cameron

 

[Jim Thomlinson]

The easiers way would be to load the data into MS Access and create a report.
As a report you can just drag the fields wherever you want them adn gropu
them as necessary

 

[Roy Wagner]

Add a command button to the source sheet and add this code to its click
event. Make sure you set the adjustments for first source row, etc as
commented in the code. Try it on a copy first.

Roy

Private Sub CommandButton1_Click()

Dim x As Long, y As Integer
Dim FirstDataRow As Integer, LastDataRow As Long
Dim DestRow As Long, DestCol As Long
Dim Src As Integer, Dest As Integer
Dim Lname As String, Fname As String
Dim Address1 As String, City As String
Dim State As String, ZipCode As String
Dim Phone As Long, WholeName As String
Dim WriteLeft As Boolean

'IMPORTANT install procedure in source sheet and...
Src = 1 'set source and dest worksheets variables (sheet 1)
Dest = 2 'if your setup is different - (sheet 2)
FirstDataRow = 2 ' set to row containing first name (source)
DestRow = 2 'assumes 1 header row, adj as needed (destination)

LastDataRow = Sheets(Src).Range("a65536").End(xlUp).Row 'find last occupied
row.
WriteLeft = True

For x = FirstDataRow To LastDataRow
'read source sheet data and convert as needed
Lname = LCase(Cells(x, 1).Value)
Lname = Application.WorksheetFunction.Proper(Lname)
Fname = LCase(Cells(x, 2).Value)
Fname = Application.WorksheetFunction.Proper(Fname)
WholeName = Lname + ", " + Fname
Address1 = LCase(Cells(x, 3).Value)
Address1 = Application.WorksheetFunction.Proper(Address1)
City = LCase(Cells(x, 4).Value)
City = Application.WorksheetFunction.Proper(City)
State = LCase(Cells(x, 5).Value)
State = Application.WorksheetFunction.Proper(State)
ZipCode = LCase(Cells(x, 6).Value)
ZipCode = Application.WorksheetFunction.Proper(ZipCode)
Phone = LCase(Cells(x, 6).Value)
Phone = Application.WorksheetFunction.Proper(Phone)

'write to destination sheet
If WriteLeft = True Then
DestCol = 1 'adjust for where you want output (Col A)
WriteLeft = False
Else
DestCol = 4 'default is cols A & D per your post (Col D)
WriteLeft = True
End If
Sheets(Dest).Cells(DestRow, DestCol).Value = WholeName
Sheets(Dest).Cells(DestRow + 1, DestCol).Value = Address1
Sheets(Dest).Cells(DestRow + 2, DestCol).Value = City + ", " + State
+ " " + ZipCode
Sheets(Dest).Cells(DestRow + 3, DestCol).Value = Phone
If WriteLeft = True Then DestRow = DestRow + 5
Next


End Sub

 

[Roy Wagner]

I apologize for the previous hasty post. My wife was rushing me to take her
out to dinner and I didn't give the outcome the best scrutiny. Below is the
corrected code. In copying and pasting to save typing, I had inadvertently
added some excess formatting changes, had a bad refernce for the phone column
and didn't give it a large enough variable to handle all 10 digit phone
numbers numbers. Yikes!

If you don't try it in Access as Jim suggests, use this corrected version.

Roy

Private Sub CommandButton1_Click()
Dim x As Long, y As Integer
Dim FirstDataRow As Integer, LastDataRow As Long
Dim DestRow As Long, DestCol As Long
Dim Src As Integer, Dest As Integer
Dim Lname As String, Fname As String
Dim Address1 As String, City As String
Dim State As String, ZipCode As String
Dim Phone As String, WholeName As String
Dim WriteLeft As Boolean
'IMPORTANT install procedure in source sheet and...
Src = 1 'set source and dest worksheets variables
Dest = 2 'if your setup is different
FirstDataRow = 2 ' set to row containing first name
DestRow = 2 'assumes 1 header row, adj as needed
LastDataRow = Sheets(Src).Range("a65536").End(xlUp).Row 'find last occupied
row.
WriteLeft = True
For x = FirstDataRow To LastDataRow
'read source sheet data and convert as needed
Lname = Application.WorksheetFunction.Proper(Cells(x, 1).Value)
Fname = Application.WorksheetFunction.Proper(Cells(x, 2).Value)
WholeName = Lname + ", " + Fname
Address1 = Application.WorksheetFunction.Proper(Cells(x, 3).Value)
City = Application.WorksheetFunction.Proper(Cells(x, 4).Value)
State = UCase(Cells(x, 5).Value)
ZipCode = Cells(x, 6).Value
Phone = Cells(x, 7).Value
'write to destination sheet
If WriteLeft = True Then
DestCol = 1 'adjust for where you want output
WriteLeft = False
Else
DestCol = 4 'default is cols A & D per your post
WriteLeft = True
End If
Sheets(Dest).Cells(DestRow, DestCol).Value = WholeName
Sheets(Dest).Cells(DestRow + 1, DestCol).Value = Address1
Sheets(Dest).Cells(DestRow + 2, DestCol).Value = City + ", " + State + "
" + ZipCode
Sheets(Dest).Cells(DestRow + 3, DestCol).Value = Format(Phone, "(###)
###-####")
If WriteLeft = True Then DestRow = DestRow + 5
Next
End Sub