Transpose column into rows for use as mailmerge data

[Nash]

I have data in the following format and would like to convert into an Excel
spreadsheet for use as mail merge database

Mr Chris Acton
ADH Services Ltd
Unit 5 The Oaks Down End
Crediton
Devon
EX17 1HN
Mr Peter Alexander
Mains Of Mause
Blairgowrie
Tayside
PH10 6TE
Mr James Anderson
Bowmer & Kirkland Ltd
High Edge Court Church Street
Belper
Derbyshire
DE56 2BW

If the addresses were only three lines then I could use the following
method. However some addresses have 5, 6 or 7 lines. Can anybody help get it
in the right format for a mailmerge?

In B1 enter this formula =INDEX($A:$A,(ROWS($1:1)-1)*3+COLUMNS($A:A))
Drag/copy across to D1.
Select B11 and drag/copy down until zeros show up.
Select columns B and copy.
Edit>Paste Special(in place)>Values>OK>Esc
Delete Column A

 

[JLatham]

I think you'll find this to be of some help. To get the code into your
workbook, open it and press [Alt]+[F11] to open the VB Editor. In the VBE,
choose Insert | Module and copy and paste the code below into the module.
Make changes to the worksheet names as required.

Be careful when you paste it into the module. The editor here often breaks
code line early. That leads to errors in the code. You may have to edit the
copied code to make broken statements one long line of code again. You can
quickly test for this by clicking [Debug] in the VBE menu and choosing
[Compile...] It will flag statements that have gotten broken up. Fix them
one at a time, using [Debug] | [Compile...] after each fix until no more
errors are highlighted.

Close the VB Editor.

To use it, choose Tools | Macro | Macros from the Excel menu and choose the
name of the macro and click the [Run] button.

I've shown how to test for honorifics as "Mr ", "Ms", "Mrs " and "Prof " so
if you have others, such as "The Honorable ", you can modify the test
statements by adding another " OR " test to each of those as necessary.

The code:

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MR
" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

 

[Nash]

JLatham,
Thank you for the very quick response. I have copied and pasted you code
into the workbook, however as you suspected, on run, it give a 'compile error
Syntax error' at this point:-

" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))

I am not such an expert at macros so do not know how to rectify this error.
Could you help?
--
Nash

I think you'll find this to be of some help. To get the code into your
workbook, open it and press [Alt]+[F11] to open the VB Editor. In the VBE,
choose Insert | Module and copy and paste the code below into the module.
Make changes to the worksheet names as required.

Be careful when you paste it into the module. The editor here often breaks
code line early. That leads to errors in the code. You may have to edit the
copied code to make broken statements one long line of code again. You can
quickly test for this by clicking [Debug] in the VBE menu and choosing
[Compile...] It will flag statements that have gotten broken up. Fix them
one at a time, using [Debug] | [Compile...] after each fix until no more
errors are highlighted.

Close the VB Editor.

To use it, choose Tools | Macro | Macros from the Excel menu and choose the
name of the macro and click the [Run] button.

I've shown how to test for honorifics as "Mr ", "Ms", "Mrs " and "Prof " so
if you have others, such as "The Honorable ", you can modify the test
statements by adding another " OR " test to each of those as necessary.

The code:

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MR
" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

I have data in the following format and would like to convert into an Excel
spreadsheet for use as mail merge database

Mr Chris Acton
ADH Services Ltd
Unit 5 The Oaks Down End
Crediton
Devon
EX17 1HN
Mr Peter Alexander
Mains Of Mause
Blairgowrie
Tayside
PH10 6TE
Mr James Anderson
Bowmer & Kirkland Ltd
High Edge Court Church Street
Belper
Derbyshire
DE56 2BW

If the addresses were only three lines then I could use the following
method. However some addresses have 5, 6 or 7 lines. Can anybody help get it
in the right format for a mailmerge?

In B1 enter this formula =INDEX($A:$A,(ROWS($1:1)-1)*3+COLUMNS($A:A))
Drag/copy across to D1.
Select B11 and drag/copy down until zeros show up.
Select columns B and copy.
Edit>Paste Special(in place)>Values>OK>Esc
Delete Column A

 

[JLatham]

It looks like the editor here pushed the first " OR _" that should be at the
end of the line above it onto a new line. I copied the code out of the
posting above, fixed the problem and have shortened everything up a bit to
where it should fit in here and still run for you. Cut and paste this over
the older code in your workbook.

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) _
= "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

JLatham,
Thank you for the very quick response. I have copied and pasted you code
into the workbook, however as you suspected, on run, it give a 'compile error
Syntax error' at this point:-

" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))

I am not such an expert at macros so do not know how to rectify this error.
Could you help?
--
Nash

I think you'll find this to be of some help. To get the code into your
workbook, open it and press [Alt]+[F11] to open the VB Editor. In the VBE,
choose Insert | Module and copy and paste the code below into the module.
Make changes to the worksheet names as required.

Be careful when you paste it into the module. The editor here often breaks
code line early. That leads to errors in the code. You may have to edit the
copied code to make broken statements one long line of code again. You can
quickly test for this by clicking [Debug] in the VBE menu and choosing
[Compile...] It will flag statements that have gotten broken up. Fix them
one at a time, using [Debug] | [Compile...] after each fix until no more
errors are highlighted.

Close the VB Editor.

To use it, choose Tools | Macro | Macros from the Excel menu and choose the
name of the macro and click the [Run] button.

I've shown how to test for honorifics as "Mr ", "Ms", "Mrs " and "Prof " so
if you have others, such as "The Honorable ", you can modify the test
statements by adding another " OR " test to each of those as necessary.

The code:

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MR
" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

I have data in the following format and would like to convert into an Excel
spreadsheet for use as mail merge database

Mr Chris Acton
ADH Services Ltd
Unit 5 The Oaks Down End
Crediton
Devon
EX17 1HN
Mr Peter Alexander
Mains Of Mause
Blairgowrie
Tayside
PH10 6TE
Mr James Anderson
Bowmer & Kirkland Ltd
High Edge Court Church Street
Belper
Derbyshire
DE56 2BW

If the addresses were only three lines then I could use the following
method. However some addresses have 5, 6 or 7 lines. Can anybody help get it
in the right format for a mailmerge?

In B1 enter this formula =INDEX($A:$A,(ROWS($1:1)-1)*3+COLUMNS($A:A))
Drag/copy across to D1.
Select B11 and drag/copy down until zeros show up.
Select columns B and copy.
Edit>Paste Special(in place)>Values>OK>Esc
Delete Column A

 

[Nash]

JLatham,

The macro works beautifully! I envy your skill.

One slight hiccup is that it puts, in the first 30 records or so, two
postcodes in the line, one correct and one picked from some other place. Now
that the new data is nicely organised, I can tidy this up manually by
comparing the original data with the new and correcting the postcode in each
line. With some addresses having 5,6 or 7 lines I am expecting to do some
manually moving of towns, country and postcodes into their correct columns.

Thank you very much for your help, you have saved my enormous amount of
time. Could you recommend a good book I can use to programme macros?

Kind regards
Nash

--
Nash

It looks like the editor here pushed the first " OR _" that should be at the
end of the line above it onto a new line. I copied the code out of the
posting above, fixed the problem and have shortened everything up a bit to
where it should fit in here and still run for you. Cut and paste this over
the older code in your workbook.

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) _
= "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

JLatham,
Thank you for the very quick response. I have copied and pasted you code
into the workbook, however as you suspected, on run, it give a 'compile error
Syntax error' at this point:-

" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))

I am not such an expert at macros so do not know how to rectify this error.
Could you help?
--
Nash

I think you'll find this to be of some help. To get the code into your
workbook, open it and press [Alt]+[F11] to open the VB Editor. In the VBE,
choose Insert | Module and copy and paste the code below into the module.
Make changes to the worksheet names as required.

Be careful when you paste it into the module. The editor here often breaks
code line early. That leads to errors in the code. You may have to edit the
copied code to make broken statements one long line of code again. You can
quickly test for this by clicking [Debug] in the VBE menu and choosing
[Compile...] It will flag statements that have gotten broken up. Fix them
one at a time, using [Debug] | [Compile...] after each fix until no more
errors are highlighted.

Close the VB Editor.

To use it, choose Tools | Macro | Macros from the Excel menu and choose the
name of the macro and click the [Run] button.

I've shown how to test for honorifics as "Mr ", "Ms", "Mrs " and "Prof " so
if you have others, such as "The Honorable ", you can modify the test
statements by adding another " OR " test to each of those as necessary.

The code:

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MR
" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub


:

I have data in the following format and would like to convert into an Excel
spreadsheet for use as mail merge database

Mr Chris Acton
ADH Services Ltd
Unit 5 The Oaks Down End
Crediton
Devon
EX17 1HN
Mr Peter Alexander
Mains Of Mause
Blairgowrie
Tayside
PH10 6TE
Mr James Anderson
Bowmer & Kirkland Ltd
High Edge Court Church Street
Belper
Derbyshire
DE56 2BW

If the addresses were only three lines then I could use the following
method. However some addresses have 5, 6 or 7 lines. Can anybody help get it
in the right format for a mailmerge?

In B1 enter this formula =INDEX($A:$A,(ROWS($1:1)-1)*3+COLUMNS($A:A))
Drag/copy across to D1.
Select B11 and drag/copy down until zeros show up.
Select columns B and copy.
Edit>Paste Special(in place)>Values>OK>Esc
Delete Column A

 

[JLatham]

Sorry about leaving some by-hand work to be done. The code doesn't know what
is present or what is not within any group since the number of lines is
variable. All it does is take each successive row within a group and place
it into the next available column on the destination sheet.

It's hard to point out books dealing with programming in VBA in Excel. The
"A" in VBA stands for "for Applications". Each application, such as Word,
Excel and Access share a core vocabulary of standard commands with objects
and commands specific to that application added. I learned my programming
skills through about 27 years of experience now, with active coding of Excel
taking place over about the past 13 years. One thing that can help a lot is
recording macros and looking at what objects and "methods" (actions) and
properties (attributes) it addresses when you perform some operations. That
can help teach you a lot about what you have to work with at times within
Excel VBA. But it doesn't teach things like looping and decision making in
code. Look for some entry level "Step by Step..." books on the subject from
Microsoft Press as one possible starting point.
Learning VBA

There are a number of site around the net to help.
http://www.mvps.org/dmcritchie/excel/getstarted.htm
http://www.the-excel-advisor.com/excel-macros-vba-tutorial.html
http://class.et.byu.edu/ce270/vbaexcel_primer/intro.htm
http://www.exceltip.com/excel_links.html

there are other sites that provide usefull information about specific issues.

http://www.contextures.com/
http://www.cpearson.com/
http://www.j-walk.com/
http://www.mcgimpsey.com/
http://www.rondebruin.nl/
http://www.mrexcel.com

JLatham,

The macro works beautifully! I envy your skill.

One slight hiccup is that it puts, in the first 30 records or so, two
postcodes in the line, one correct and one picked from some other place. Now
that the new data is nicely organised, I can tidy this up manually by
comparing the original data with the new and correcting the postcode in each
line. With some addresses having 5,6 or 7 lines I am expecting to do some
manually moving of towns, country and postcodes into their correct columns.

Thank you very much for your help, you have saved my enormous amount of
time. Could you recommend a good book I can use to programme macros?

Kind regards
Nash

--
Nash

It looks like the editor here pushed the first " OR _" that should be at the
end of the line above it onto a new line. I copied the code out of the
posting above, fixed the problem and have shortened everything up a bit to
where it should fit in here and still run for you. Cut and paste this over
the older code in your workbook.

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) _
= "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) _
= "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub

JLatham,
Thank you for the very quick response. I have copied and pasted you code
into the workbook, however as you suspected, on run, it give a 'compile error
Syntax error' at this point:-

" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))

I am not such an expert at macros so do not know how to rectify this error.
Could you help?
--
Nash


:

I think you'll find this to be of some help. To get the code into your
workbook, open it and press [Alt]+[F11] to open the VB Editor. In the VBE,
choose Insert | Module and copy and paste the code below into the module.
Make changes to the worksheet names as required.

Be careful when you paste it into the module. The editor here often breaks
code line early. That leads to errors in the code. You may have to edit the
copied code to make broken statements one long line of code again. You can
quickly test for this by clicking [Debug] in the VBE menu and choosing
[Compile...] It will flag statements that have gotten broken up. Fix them
one at a time, using [Debug] | [Compile...] after each fix until no more
errors are highlighted.

Close the VB Editor.

To use it, choose Tools | Macro | Macros from the Excel menu and choose the
name of the macro and click the [Run] button.

I've shown how to test for honorifics as "Mr ", "Ms", "Mrs " and "Prof " so
if you have others, such as "The Honorable ", you can modify the test
statements by adding another " OR " test to each of those as necessary.

The code:

Sub TransposeAddresses()
Const sourceSheetName = "Sheet1"
Const destSheetName = "Sheet2"
Dim destBaseCell As Range
Dim srcList As Range
Dim anySrcEntry As Range
Dim colOffset As Integer ' on dest sheet
Dim rowOffset As Long ' on dest sheet
Dim sRowOffset As Long ' on source sheet

'set up references to worksheet areas
Set destBaseCell = _
Worksheets(destSheetName).Range("A2")
Set srcList = _
Worksheets(sourceSheetName).Range("A2:A" & _
Worksheets(sourceSheetName).Range("A" & _
Rows.Count).End(xlUp).Row)
'assumes that all names begin with
'some honorific as "Mr ", "Ms ", "Dr " etc.
'you'll need to come up with a list
rowOffset = -1 ' initialize
For Each anySrcEntry In srcList
If UCase(Left(Trim(anySrcEntry), 3)) = "MR " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Then
colOffset = 0 ' reset
rowOffset = rowOffset + 1 ' increment
'move the name
destBaseCell.Offset(rowOffset, colOffset) = anySrcEntry
'loop through remainder of the address
sRowOffset = 1 ' reset
Do Until UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MR
" Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "MS " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 3)) = "DR " Or _
UCase(Left(Trim(anySrcEntry.Offset(sRowOffset, 0)), 4)) = "MRS " Or _
UCase(Left(Trim(anySrcEntry), 5)) = "PROF " Or _
IsEmpty(anySrcEntry.Offset(sRowOffset, 0))
colOffset = colOffset + 1
destBaseCell.Offset(rowOffset, colOffset) = _
anySrcEntry.Offset(sRowOffset, 0)
sRowOffset = sRowOffset + 1
Loop
End If
Next ' end of srcList loop
'cleanup and release resources
Set destBaseCell = Nothing
Set srcList = Nothing
End Sub


:

I have data in the following format and would like to convert into an Excel
spreadsheet for use as mail merge database

Mr Chris Acton
ADH Services Ltd
Unit 5 The Oaks Down End
Crediton
Devon
EX17 1HN
Mr Peter Alexander
Mains Of Mause
Blairgowrie
Tayside
PH10 6TE
Mr James Anderson
Bowmer & Kirkland Ltd
High Edge Court Church Street
Belper
Derbyshire
DE56 2BW

If the addresses were only three lines then I could use the following
method. However some addresses have 5, 6 or 7 lines. Can anybody help get it
in the right format for a mailmerge?

In B1 enter this formula =INDEX($A:$A,(ROWS($1:1)-1)*3+COLUMNS($A:A))
Drag/copy across to D1.
Select B11 and drag/copy down until zeros show up.
Select columns B and copy.
Edit>Paste Special(in place)>Values>OK>Esc
Delete Column A