Rows to Columns

[phendrena]

Hello again,

I have a workbook (i have many actually) that currently has it data rather oddly arranged in Rows rather than columns (not my idea, but it's what i've got work with).

It's arranged as such :

Dealer No | Salesperson | Email | User ID | Password

It then repeats the Salesperson/Email/User Id/Password across the row for each and every salesperson at that dealership. Frankly its really badly setup and an utter pain to work with.

Is there an easy way that i can move the data from rows to colums quickly?

Thanks,

(i can't post the workbook due to confidenitality)

[Bob Phillips]

Then create an example workbook with made up data but showing the structure.

[phendrena]

Here is an example for you

Thanks xld

[rbrhodes]

Hi ph,

Here's something to get you started. To see the code Right click on the sheet tab and choose 'View Code'. There's a section marked 'User' that could be set up...

[david000]

Sub test()
    Dim c As Range
    Dim wk As Worksheet
    Dim lc As Long
    Dim col As Long
    Set wk = ActiveSheet
    With wk
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    For col = 5 To lc Step 5
        Set c = .Range("K1:O1")
        c.Copy Destination:=.Range("F" & Rows.Count).End(xlUp).Offset(1, 0)
        c.EntireColumn.Delete Shift:=xlToLeft
    Next col
    End With
End Sub

[phendrena]

Hi ph,

Here's something to get you started. To see the code Right click on the sheet tab and choose 'View Code'. There's a section marked 'User' that could be set up...

That doesn't seem to work with excel 97, errors : Cut method of Range class failed

and highlights : Range(Cells(GetRow, Counter), Cells(GetRow, Counter + (NumOfCols - 1))).Cut Cells(PutRow, DestCol)

Sub test()
Dim c As Range
Dim wk As Worksheet
Dim lc As Long
Dim col As Long
Set wk = ActiveSheet
With wk
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    For col = 5 To lc Step 5
        Set c = .Range("K1:O1")
        c.Copy Destination:=.Range("F" & Rows.Count).End(xlUp).Offset(1, 0)
        c.EntireColumn.Delete Shift:=xlToLeft
    Next col
End With
End Sub

Thanks for the above, it kind of works, but doesn't give the results i'm after.

I've added a revised workbook, hopefully it'll make things a little clearer.

Thanks for the replies so far.

[david000]

Well, never hurts to to try again!

I had a hard time thinking in terms of columns so I used transpose a bunch of times. The attachment makes more sense, in so far as you can see that I used a new sheet etc, etc.

Sub aaa()
Dim lr As Long, r As Integer, y As Integer, x As Integer
Dim i As Integer, filRng As Range
With Sheet14 'get some data!
    .Range("a1:i1").Copy Sheet1.Range("b1")
    lr = .cells(.Rows.Count, 1).End(xlUp).Row
    For r = lr To 2 Step -1
        .Rows(r).EntireRow.Copy
        Sheet1.Range("a1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        With Sheet1 'move it around a bit
            lr = .cells(.Rows.Count, 1).End(xlUp).Row
            For i = lr To 5 Step -5
                .Range(.cells(i, 1), .cells(i - 4, 1)).Copy
                .Range("F" & .cells(.Rows.Count, "F").End(xlUp).Row).Offset(1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            Next i
            .Range("a1:a4").Copy
            .Range("b" & .cells(.Rows.Count, "b").End(xlUp).Row).Offset(1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            y = .cells(.Rows.Count, 2).End(xlUp).Row
            x = .cells(.Rows.Count, 6).End(xlUp).Row
            Set filRng = .Range(.cells(y, 2), .cells(x, 5))
            'MsgBox filRng.Address
            .Range("B" & y).Resize(, 4).AutoFill filRng
        End With
    Next r
End With
Columns("B:J").AutoFit
Columns(1).Delete
End Sub

[phendrena]

Cool (Interesting that it's working upwards when moving the data),

It works, but errors after moving data from 10 rows.

Error : AutoFill method of Range class failed.
Highlights : .Range("B" & y).Resize(, 4).AutoFill filRng

Any suggestions on how i can get round this?

Thanks for your help so far.


edit : If it helps, there are 725 rows with approx 3000 users

[david000]

Any suggestions on how i can get round this?

Hum, I was worried about that. I don't have Excel 97, but you can try a couple things. I have a MsgBox right before that line un-comment out that line and see what it shows. Check the help files for missing necessary data.


otherwise, this works too.

.Range(.cells(y, 2), .cells(x, 5)).Value = .Range("B" & y).Resize(, 4).Value

[rbrhodes]

Another version:

Option Explicit

Sub DoIt()
Dim GetRow As Long
Dim PutRow As Long
Dim LastRow As Long
Dim LastCol As Long
Dim DestCol As Long
Dim cCounter As Long
Dim rCounter As Long
Dim NumOfCols As Long
'//Begin User
    'Row to get data from
    GetRow = 2
'Column to put, "E" = 5
    DestCol = 5
'Number of Columns at a time
    NumOfCols = 5
'Get last row of data to convert
    LastRow = Range("E" & Rows.Count).End(xlUp).Row
'//End User
'Speed
    Application.ScreenUpdating = False
'Get first destination row
    PutRow = LastRow + 1
'Do all rows/cols
    For rCounter = GetRow To LastRow
    'Get last column of data to convert (this row)
    LastCol = Cells(rCounter, Columns.Count).End(xlToLeft).Column
    'Check if needed
    If LastCol > 9 Then
        'Do all Cols
        For cCounter = DestCol + NumOfCols To LastCol Step NumOfCols
            'Insert a row
            Cells(rCounter + 1, 1).EntireRow.Insert
            'Cut/Paste block of cells
            Range(Cells(rCounter, cCounter).Address, Cells(rCounter, cCounter + (NumOfCols - 1)).Address).Cut Cells(PutRow, DestCol)
            'Increment destination row
            'PutRow = PutRow + 1
        Next cCounter
        'Copy&Paste
        Range("A" & GetRow & ":E" & GetRow).Copy Range("A2:A" & PutRow - 1)
    End If
    Next rCounter
'Clear old
    Range("J1:IV65536").Clear
'Reset
    With Application
    .ScreenUpdating = True
    .CutCopyMode = False
    End With
End Sub

[phendrena]

Still can't either of the solutions above to work correctly.

David000 - Yours still errors after moving some data, I uncommented the msgbox line and displays the following : $B$2:$E$9 and then keeps popping them up....

rbrhodes - Yours likes to copy the first entry multiple times and doesn't move all the data.

any further suggestions?

Thanks,

[david000]

Well, I'm out of suggestions, and that was the correct address the MsgBox was showing. So, all I can say is, try commenting out these lines.

'Set filRng = .Range(.cells(y, 2), .cells(x, 5))
'MsgBox filRng.Address
'.Range("B" & y).Resize(, 4).AutoFill filRng

with this one

.Range(.cells(y, 2), .cells(x, 5)).Value = .Range("B" & y).Resize(, 4).Value

I want to eliminate the line with AutoFill. I tried this on Excel 2003 and 2007.

I'm sure there's a solution to this!

[rbrhodes]

Hi,

Borrowed the backwords idea from David0. I've tested this and it worked for me...

Option Explicit
Sub DoIt2It()
Dim LastRow As Long
Dim LastCol As Long
Dim DestCol As Long
Dim cCounter As Long
Dim rCounter As Long
Dim NumOfCols As Long
'Column to put, "E" = 5
DestCol = 5
'Number of Columns at a time
NumOfCols = 5
'Get last row of data to convert
LastRow = Range("E" & Rows.Count).End(xlUp).Row
'Speed
Application.ScreenUpdating = False
'Do all rows/cols (skip header row)
For rCounter = LastRow To 2 Step -1
    'Get last column of data to convert (this row)
    LastCol = Cells(rCounter, Columns.Count).End(xlToLeft).Column
    'Check if needed
    If LastCol > 9 Then
        'Do all Cols
        For cCounter = DestCol + NumOfCols To LastCol Step NumOfCols
            'Insert a row
            Cells(rCounter + 1, 1).EntireRow.Insert
            'Cut/Paste block of cells
            Range(Cells(rCounter, cCounter).Address, Cells(rCounter, cCounter + (NumOfCols - 1)).Address).Cut Cells(rCounter + 1, DestCol)
            'Copy&Paste
            Range("A" & rCounter & ":E" & rCounter).Copy Range("A" & rCounter + 1)
        Next cCounter
    End If
Next rCounter
'Reset
With Application
    .ScreenUpdating = True
    .CutCopyMode = False
End With
End Sub

[phendrena]

Apologies for not getting back quicker on this one as it's been a project on the back burner that i've just come back to.
I'm pleased to report that the above code work exceedingly well.

Many thanks.

[rbrhodes]

Cheers,

dr