Transposing hundreds of addresses in a column using VBA

A

andreas

Dear Experts:
I got hundreds of addresses in an excel sheet which need to be
transposed. The addresses are all in one column and arranged as
follows:

Name
Street
City
Tel
Blank row (1 to several)
Name Street
City
Tel
Blank row (1 to several)
etc. (another several hundred addresses more)

A macro should loop thru all these addresses and do the transposing
automatically. The addresses that are transposed should be placed
right next to each and every address.

Help is much appreciated. Thank you very much in advance. Regards,
Andreas
 
N

Normek

Hi andreas
Try something like this?

Sub transposeAddress()
Application.ScreenUpdating = False
Dim SpaceCount As Integer
Dim TransposeRow As Integer
Dim Transpose As Range
SpaceCount = 0
TransposeCount = 0
Set TransposeCell = Range("C1") 'Select your own cell
Range("A1").Select 'Select your own cell
While SpaceCount < 10 ' select your value
If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Select
SpaceCount = SpaceCount + 1
Else
TransposeCell.Offset(TransposeCount, 0) = ActiveCell.Offset(0, 0)
TransposeCell.Offset(TransposeCount, 1) = ActiveCell.Offset(1, 0)
TransposeCell.Offset(TransposeCount, 2) = ActiveCell.Offset(2, 0)
TransposeCell.Offset(TransposeCount, 3) = ActiveCell.Offset(3, 0)
TransposeCount = TransposeCount + 1
SpaceCount = 0
ActiveCell.Offset(4, 0).Select
End If

Wend
End Sub
 
J

Joel

Try this code

Sub CombineRows()

LastRow = Range("A" & Rows.Count).End(xlUp).Row
'set rowcount to row where you want 1st entry
RowCount = 1
NewRow = RowCount
Start = False
Do While RowCount <= LastRow
If Start = False Then
If Range("A" & RowCount) <> "" Then
Start = True
StartRow = RowCount
End If

Else
If Range("A" & (RowCount + 1)) = "" Then
ColCount = 1
For MoveRow = StartRow To RowCount
Cells(NewRow, ColCount) = Cells(MoveRow, "A")
ColCount = ColCount + 1
Next MoveRow
NewRow = NewRow + 1
Start = False
End If
End If
RowCount = RowCount + 1
Loop

Rows(NewRow & ":" & LastRow).Delete

End Sub
 
R

Ron Rosenfeld

Dear Experts:
I got hundreds of addresses in an excel sheet which need to be
transposed. The addresses are all in one column and arranged as
follows:

Name
Street
City
Tel
Blank row (1 to several)
Name Street
City
Tel
Blank row (1 to several)
etc. (another several hundred addresses more)

A macro should loop thru all these addresses and do the transposing
automatically. The addresses that are transposed should be placed
right next to each and every address.

Help is much appreciated. Thank you very much in advance. Regards,
Andreas
Click to expand...

I don't know what you mean when you write
The addresses that are transposed should be placed
right next to each and every address.
Click to expand...

But to transpose a column of address entries, that are located in, let us say,
A2:An, you could use this macro.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro
by name, and <RUN>.

============================================
Option Explicit
Sub TranspAdr()
'Assumes every address group has at least two rows
'Does not test for this
Dim rSrc As Range, rDest As Range, c As Range
Dim i As Long

Set rSrc = Range("A2")
Set rDest = Range("B1")

i = 1
Do
Set rSrc = Range(rSrc, rSrc.End(xlDown))
rSrc.Copy
rDest(i, 1).PasteSpecial Transpose:=True
Application.CutCopyMode = False
Set rSrc = rSrc.End(xlDown).End(xlDown)
i = i + 1
Loop Until rSrc.End(xlDown).Row = Cells.Rows.Count
End Sub
=================================
--ron
 
A

andreas

Hi andreas
Try something like this?

Sub transposeAddress()
Application.ScreenUpdating = False
Dim SpaceCount As Integer
Dim TransposeRow As Integer
Dim Transpose As Range
SpaceCount = 0
TransposeCount = 0
Set TransposeCell = Range("C1") 'Select your own cell
Range("A1").Select          'Select your own cell
While SpaceCount < 10 ' select your value
    If ActiveCell.Value = "" Then
         ActiveCell.Offset(1, 0).Select
         SpaceCount = SpaceCount + 1
    Else
        TransposeCell.Offset(TransposeCount, 0) = ActiveCell.Offset(0, 0)
        TransposeCell.Offset(TransposeCount, 1) = ActiveCell.Offset(1, 0)
        TransposeCell.Offset(TransposeCount, 2) = ActiveCell.Offset(2, 0)
        TransposeCell.Offset(TransposeCount, 3) = ActiveCell.Offset(3, 0)
        TransposeCount = TransposeCount + 1
        SpaceCount = 0
        ActiveCell.Offset(4, 0).Select
    End If

 Wend
End Sub
Click to expand...

Hi Normek,

that's it. Thank you very much for your professional help. Regards,
Andreas
 
A

andreas

Try this code

Sub CombineRows()

LastRow = Range("A" & Rows.Count).End(xlUp).Row
'set rowcount to row where you want 1st entry
RowCount = 1
NewRow = RowCount
Start = False
Do While RowCount <= LastRow
   If Start = False Then
      If Range("A" & RowCount) <> "" Then
         Start = True
         StartRow = RowCount
      End If

   Else
      If Range("A" & (RowCount + 1)) = "" Then
         ColCount = 1
         For MoveRow = StartRow To RowCount
            Cells(NewRow, ColCount) = Cells(MoveRow, "A")
            ColCount = ColCount + 1
         Next MoveRow
         NewRow = NewRow + 1
         Start = False
      End If
   End If
   RowCount = RowCount + 1
Loop

Rows(NewRow & ":" & LastRow).Delete

End Sub








- Zitierten Text anzeigen -
Click to expand...

Hi Joel,

it is working as desired. Thank you very much for your terrific help.
Regards, Andreas
 
A

andreas

I don't know what you mean when you write


But to transpose a column of address entries, that are located in, let ussay,
A2:An, you could use this macro.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro
by name, and <RUN>.

============================================
Option Explicit
Sub TranspAdr()
'Assumes every address group has at least two rows
'Does not test for this
Dim rSrc As Range, rDest As Range, c As Range
Dim i As Long

Set rSrc = Range("A2")
Set rDest = Range("B1")

i = 1
Do
    Set rSrc = Range(rSrc, rSrc.End(xlDown))
    rSrc.Copy
    rDest(i, 1).PasteSpecial Transpose:=True
    Application.CutCopyMode = False
    Set rSrc = rSrc.End(xlDown).End(xlDown)
    i = i + 1
Loop Until rSrc.End(xlDown).Row = Cells.Rows.Count
End Sub
=================================
--ron- Zitierten Text ausblenden -

- Zitierten Text anzeigen -
Click to expand...

Hi Ron,

did a couple of adjustments and now it is working as desired. Thank
you very much for your terrific help. Regards, Andreas
 
R

Ron Rosenfeld

Hi Ron,

did a couple of adjustments and now it is working as desired. Thank
you very much for your terrific help. Regards, Andreas
Click to expand...

Glad to help. Thanks for the feedback.
--ron
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Address Transposing 1
Array with many cells from a row but not in order or together 11
Grey Fill for all cells that contain a certain string in hyperlinkaddress 4
Transposing 2
Copy each data record of a name list and place it under the onecopied 2
Insert a space in all blank cells of the first column 4
Run macro on all files in a specific folder 3
Create several charts in one go using VBA 4

Top