Excel Macro to move Rows to Columns

Microsoft Excel 2007
January 13, 2010 at 23:23:10
Specs: Windows Vista
I am trying to move data from a single column on one sheet to multiple columns on another. Here is a sample of my data:
====================================
1

A-0614
MR ASAD SIBTAIN
HOUSE NO 149 - B, D.H.A - LAHORE Tel: 5898949-5761882, -

2
A-0653
MR BABAR SHAFI
89 - AIBAK BLOCK, NEW GARDEN TOWN, - LAHORE Tel:
9201158-5867627, -


3
A-0691
MR MOHAMMAD IRFAN AKRAM
1429 - TUFAIL ROAD, - - LAHRE CANTT Tel: 5803255-665300, -
====================================
This is all in one column. Using this macro:

Option Explicit
Sub Macro1()
Dim Row%, xCol%, xRow%, Col%, Max%

Col% = ActiveCell.Column
Row% = ActiveCell.Row
xRow% = Row%
xCol% = 1
Max% = Selection.Count

Do
If Cells(Row%, Col%) <> "" Then
Sheet2.Cells(1, xCol%) = Cells(Row%, Col%)
End If
Row% = Row% + 1
xCol% = xCol% + 1
Loop Until xCol% > Max%
End Sub

I get this output all in one row but different columns:
==================================
1 A-0614 MR ASAD SIBTAIN HOUSE NO 149 - B, D.H.A - LAHORE Tel: 5898949-5761882, - 2 A-0653 MR BABAR SHAFI 89 - AIBAK BLOCK, NEW GARDEN TOWN, - LAHORE Tel: 9201158-5867627, - 3 A-0691 MR MOHAMMAD IRFAN AKRAM 1429 - TUFAIL ROAD, - - LAHRE CANTT Tel: 5803255-665300, -

==================================
I need this macro to create a new row whenever it comes across a lone number in the column. This is what i would like the output to be :

1 A-0614 MR ASAD SIBTAIN HOUSE NO 149 - B, D.H.A - LAHORE Tel: 5898949-5761882, -

//second row starts here
2 A-0653 MR BABAR SHAFI 89 - AIBAK BLOCK, NEW GARDEN TOWN, - LAHORE Tel: 9201158-5867627, -

// Third row starts here
3 A-0691 MR MOHAMMAD IRFAN AKRAM 1429 - TUFAIL ROAD, - - LAHRE CANTT Tel: 5803255-665300, -



See More: Excel Macro to move Rows to Columns

Report •

#1
January 14, 2010 at 06:38:34
Hi,
I think that the following macro will do what you want.

I have added comments to most lines so that you can see what is happening.

I used a boolean 'flag' to stop the macro moving to a new line for the first entry.

I also changed the way the source data range is selected - this way means that you do not have to select all the cells. Just select the first cell with data - '1' in your example.
I used .End(xlUp) to find the last cell in the selected column that has data.

I added a few lines to separate out the telephone number into a separate column. The code looks for the word 'Tel' in the text and if it finds Tel, it splits the text up into two columns.

You might be able to extend this technique to separate other parts of the addresses.

I used the 'for each in' structure to loop through all the cells in the source range.

For Each rngCell In Range(rngFirstSrc, rngLastSrc).
This saves having to increment row counters in the source data and provides easy access to the source data - rngCell.Value or rngCell.Text, as rngCell has all the attributes of each cell in the range, in turn.

Sub macro2()
Dim rngFirstSrc As Range
Dim rngLastSrc As Range
Dim intDestCol As Integer
Dim intDestRow As Integer
Dim rngCell As Range
Dim blnFirst As Boolean

'set flag for First address
blnFirst = True
'Get first cell in range
Set rngFirstSrc = ActiveCell
'find last entry in column
Set rngLastSrc = Cells(65534, ActiveCell.Column).End(xlUp)
'set first destination column
intDestCol = 1
'set first destination row
intDestRow = 1
'loop through all source cells
For Each rngCell In Range(rngFirstSrc, rngLastSrc)
    'only do something if the source cell is not empty
    If rngCell.Value <> "" Then
        'test if there is a number in the cell, and its not the first address found
        If IsNumeric(rngCell.Value) And blnFirst = False Then
            'then test that it is less than 1000
            If rngCell.Value < 1000 Then
                'go to next row in destination
                intDestRow = intDestRow + 1
                'reset column counter
                intDestCol = 1
            End If
            ElseIf IsNumeric(rngCell.Value) And rngCell.Value < 1000 Then
            'change first address flag when first number <1000 found
            blnFirst = False
        End If
        'copy cell contents
        'but first see if it contains 'Tel'
        If InStr(1, rngCell.Text, "Tel") = 0 Then
            'if Tel is not in the text copy all the data in the cell
            Worksheets("Sheet2").Cells(intDestRow, intDestCol).Value = rngCell.Value
            Else
            'copy the data as two items with Tel.No. in next column
            Worksheets("Sheet2").Cells(intDestRow, intDestCol).Value = _
                Left(rngCell.Text, InStr(1, rngCell.Text, "Tel") - 1)
            'increment column counter
            intDestCol = intDestCol + 1
            Worksheets("Sheet2").Cells(intDestRow, intDestCol).Value = _
                Right(rngCell.Text, Len(rngCell.Text) - InStr(1, rngCell.Text, "Tel") + 1)
        End If
        'increment column counter
        intDestCol = intDestCol + 1
    End If
Next rngCell
End Sub

Regards


Report •

#2
January 14, 2010 at 12:42:09
Humar .... You are the MAN !! that was brilliant .. it helped me get the huge data i had in the exact order that i wanted it. The comments that you made in your code were really helpful as i was also able to modify the code to pick out specific kinds of telephone numbers.

I must say a very well formatted and properly indented code :)

Thanks for the help


Report •

#3
January 15, 2010 at 04:50:04
You're Welcome,

and thanks for your message, it was much appreciated.

Regards

Humar


Report •
Related Solutions


Ask Question