Transpose row's of data & when blank move on to next row

M

Maria

New member
Joined
Aug 7, 2011
Messages
1
Reaction score
0
Points
0
I have several rows of data of varying lengths. I need to take each row of data, transpose it to a new sheet, so the data is in a single column. Then transpose the next row of data directly under that. This process needs to be automatic, so when excel gets to the end of the row(e.g (value = 0) it knows to move on to the next row & start populating that data. When two rows return a zero value the formula / loop should stop.

Any ideas?
 
Hello Maria

On the assumption that your data is in a contigious range (no blank rows or columns) and there a no blank cells in any row of data, the following may be a good starting point for you:

Code: 
Worksheets("Sheet1").Activate [COLOR=darkgreen]'Worksheet containing data.[/COLOR]
[COLOR=blue]Set[/COLOR] ws = Worksheets("Sheet2") [COLOR=darkgreen]'Destination worksheet.[/COLOR]
 [COLOR=darkgreen]'Clear destination existing data.[/COLOR]
[COLOR=blue]If[/COLOR] ws.Range("A1").Value <> "" [COLOR=blue]Then[/COLOR] 
    ws.Range("A1").CurrentRegion.ClearContents 
[COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
iRows = 1 
 [COLOR=darkgreen]'Reference Sheet1 data range.[/COLOR]
[COLOR=blue]Set[/COLOR] rng = Range("A1").CurrentRegion 
[COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] rng [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] 
    [COLOR=blue]For[/COLOR] r = 1 [COLOR=blue]To[/COLOR] rng.Rows.Count 
        [COLOR=blue]For[/COLOR] c = 1 [COLOR=blue]To[/COLOR] rng.Columns.Count 
            [COLOR=blue]If[/COLOR] Cells(r, c) <> vbNullString [COLOR=blue]Then[/COLOR] 
                [COLOR=blue]With[/COLOR] ws 
                    .Cells(iRows, 1) = Cells(r, c).Value 
                    iRows = iRows + 1 
                [COLOR=blue]End With[/COLOR] 
            [COLOR=blue]Else[/COLOR] 
                Exit [COLOR=blue]For[/COLOR] 
            [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
        [COLOR=blue]Next[/COLOR] 
    [COLOR=blue]Next[/COLOR] 
[COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
[COLOR=blue]Set[/COLOR] ws = [COLOR=blue]Nothing[/COLOR] 
[COLOR=blue]Set[/COLOR] rng = [COLOR=blue]Nothing[/COLOR]

Jess
 
Last edited by a moderator:
An alternative

Code: 
Sub TransformData()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastrow As Long
Dim lastcol As Long
Dim nextrow As Long
Dim i As Long

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
 
    ws2.UsedRange.ClearContents

    With ws1
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        nextrow = 1
        For i = 1 To lastrow
        
            lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column
            .Cells(i, "A").Resize(, lastcol).Copy
            ws2.Cells(nextrow, "A").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            nextrow = nextrow + lastcol
        Next i
    End With
End Sub
 
You must log in or register to reply here.
Back
Top