Changing Mailing labels from rows to columns

L

lucrezia

Hi helpful people,

I have imported a list of mailing labels. So all the data for each
vendor is in separate rows, in one columns. I want to make these into
different columns.

Labels currently look like this:

Atrium Business Centre
200, 839 5th Avenue SW
Calgary, Alberta
T2P 3C8


I want to have columns like this

Business Name Address1 Adress2 City
PCode


I can use the "paste special/transpose" and make it work on one label
at a time, but I was wondering if there is an easier way to do all at
once?

Possible complications are:

- There are a varying number of rows the information is in, sometimes 3
rows, sometimes 4 depending on the address

- There are 2 blank rows between each set of data.

Help is appreciated. Thanks

Mary
 
J

JLatham

This code doesn't care how many rows make up an address, 1, 2, 4, 10 - it
doesn't care. It also doesn't care if there is 1, 2 or 47 blank rows between
address groups. It DOES presume that an empty cell in the source column
signifies the end of one address group and prepares to treat the next
not-empty cell in the column as the Name/start of another address group.

You'll need to make 3 changes to this code: replace 'Sheet1' and 'Sheet2'
with the real names of sheets in your workbook, and if you don't want to
start looking for a name in Sheet1!A1, then change the SRange cell address
along with the column to look in when LRTC is defined.

DRange should point to the first cell you want to put the first name found
into.

Sub TransposeGroups()
Dim SRange As Range ' source range
Dim DRange As Range ' destination range
Dim SourceRO As Long ' SourceRowOffset
Dim DestRO As Long ' destination row offset
Dim DestCO As Integer ' destination column offset
Dim LRTC As Long 'last row to check
'
'define SRange and DRange for your workbook
'
Set SRange = Worksheets("Sheet1").Range("A1")
Set DRange = Worksheets("Sheet2").Range("A1")
'
'match sheet name here with source sheet to be used
'
LRTC = _
Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Do Until SourceRO > LRTC
If Not IsEmpty(SRange.Offset(SourceRO, 0)) Then
DRange.Offset(DestRO, DestCO) = _
SRange.Offset(SourceRO, 0)
DestCO = DestCO + 1
Else
'empty cell, update pointers
DestCO = 0
If Not (IsEmpty(DRange.Offset(DestRO, DestCO))) Then
DestRO = DestRO + 1
End If
End If
SourceRO = SourceRO + 1
Loop
End Sub
 
L

lucrezia

I get what this is doing basically, but haven't really done anything
like this in Excel before, so I don't actually know how I am supposed
to utilize the code.

I have two sheets the source sheet is called Labels and the starting
cell is A1. The desitnation sheet is called list and the starting cell
would be A1.

Where would I put the code to make it work?
 
J

JLatham

Revised code with your sheet names in it:
Sub TransposeGroups()
Dim SRange As Range ' source range
Dim DRange As Range ' destination range
Dim SourceRO As Long ' SourceRowOffset
Dim DestRO As Long ' destination row offset
Dim DestCO As Integer ' destination column offset
Dim LRTC As Long 'last row to check
'
'define SRange and DRange for your workbook
'
Set SRange = Worksheets("Labels").Range("A1")
Set DRange = Worksheets("list").Range("A1")
'
'match sheet name here with source sheet to be used
'
LRTC = _
Worksheets("Labels").Range("A" & Rows.Count).End(xlUp).Row
Do Until SourceRO LRTC
If Not IsEmpty(SRange.Offset(SourceRO, 0)) Then
DRange.Offset(DestRO, DestCO) = _
SRange.Offset(SourceRO, 0)
DestCO = DestCO + 1
Else
'empty cell, update pointers
DestCO = 0
If Not (IsEmpty(DRange.Offset(DestRO, DestCO))) Then
DestRO = DestRO + 1
End If
End If
SourceRO = SourceRO + 1
Loop
End Sub

Just copy that and paste into a code module in the Excel workbook. To get
to where you need to paste it, open the workbook and use [Alt]+[F11] to open
the VB Editor. If the big area is gray, use [Alt]+ followed by [M] to
Insert a new Module. Just paste the code into there and close the VB Editor.
Go to Tools | Macros | Macro and highlight the one named TransposeGroups and
hit the [Run] button. Should take about as long as it takes you to say wow
to work unless there are a heck of a lot of entries on the source sheet.
 
J

JLatham

Copying and messing with the code to set it up for your workbook hosed up one
of the lines of code, or so it seems in my preview, so here it is again - the
line of code changed is
Do Until SourceRO > LRTC
looks like I lost the > symbol somewhere in translation. Also, lines that
end with a space and the underscore character ( _) are actually lines that
are continued on the next line. They should work with copy and paste just
fine unless an extra character gets added after the underscore character.

Sub TransposeGroups()
Dim SRange As Range ' source range
Dim DRange As Range ' destination range
Dim SourceRO As Long ' SourceRowOffset
Dim DestRO As Long ' destination row offset
Dim DestCO As Integer ' destination column offset
Dim LRTC As Long 'last row to check
'
'define SRange and DRange for your workbook
'
Set SRange = Worksheets("Labels").Range("A1")
Set DRange = Worksheets("list").Range("A1")
'
'match sheet name here with source sheet to be used
'
LRTC = _
Worksheets("Labels").Range("A" & Rows.Count).End(xlUp).Row
Do Until SourceRO > LRTC
If Not IsEmpty(SRange.Offset(SourceRO, 0)) Then
DRange.Offset(DestRO, DestCO) = _
SRange.Offset(SourceRO, 0)
DestCO = DestCO + 1
Else
'empty cell, update pointers
DestCO = 0
If Not (IsEmpty(DRange.Offset(DestRO, DestCO))) Then
DestRO = DestRO + 1
End If
End If
SourceRO = SourceRO + 1
Loop
End Sub
 
Top