Transpose Macro

[levanoj]

I need macro than can basically transpose the Sheet1 on my workbook onto Sheet2 as shown below:

Book1
	A	B	C	D	E	F
1	LineID	UserID	UserID	UserID	UserID	UserID
2	1024	1302	1342	1343	1399
3	1025	1373	1374	1375	1376	1399
4	1030
5	1031	1373	1374
6	1032
7	1033
8	1034	1373	1374
Sheet1

Book1
	A	B	C	D
1	LineID	UserID
2	1024	1302
3	1024	1342
4	1024	1343
5	1024	1399
6	1025	1373
7	1025	1374
8	1025	1375
9	1025	1376
10	1025	1399
11	1030
12	1031	1373
13	1031	1374
14	1032
15	1033
16	1034	1373
17	1034	1374
Sheet2

The columns and rows may vary depending on the file so the above is just an example.

 

[kpark91]

Will all the rows be filled up?
I mean, in a row, there won't be any empty cells and then more data?

 

[ChrisM]

I've written a transpose macro for my personal add-in. Here's the code. it will ask you how many columns to keep on the left. These are the fixed columns, in your case just LineID, so you would enter 1. It will also ask you if you want a primary key, this is for moving to Access, just enter N.

Sub Transposer()
'highlight a range, including headers, then run macro
'prompt for how many columns on left to repeat
'optional: insert a primary key row (uniquely number rows, for later cross-referencing)

Dim i As Long, j As Long
Dim k As Long, z As Long
Dim outputDest As String
Dim aSrc() As Variant
Dim aWork() As Variant
Dim KeepCols As String
Dim srcRowCount As Long
Dim srcColCount As Long
Dim aRngSplit As Variant
Dim PrimaryKey As String

'Abort if a range isn't selected
If TypeName(Selection) <> "Range" Then Exit Sub

outputDest = InputBox("Enter destination address (ex Sheet1!A1)")
If outputDest = "" Then Exit Sub

KeepCols = InputBox("Enter number of columns to repeat on left side")
If KeepCols = "" Then Exit Sub
If Not IsNumeric(KeepCols) Then Exit Sub

PrimaryKey = "n"
PrimaryKey = InputBox("Enter 'y' to include a primary key column")
If LCase(PrimaryKey) <> "y" Then PrimaryKey = "n"

aSrc = Selection
srcRowCount = UBound(aSrc, 1)
srcColCount = UBound(aSrc, 2)

If PrimaryKey = "n" Then
    ReDim aWork(1 To (srcRowCount * (srcColCount - KeepCols)), 1 To KeepCols + 2)
Else
    ReDim aWork(1 To (srcRowCount * (srcColCount - KeepCols)), 1 To KeepCols + 2 + 1)
End If

z = 1
For i = 2 To srcRowCount 'start at 2 because first row headers
    For k = 1 To srcColCount - KeepCols
        If PrimaryKey = "n" Then
            For j = 1 To KeepCols
                aWork(z, j) = aSrc(i, j)
            Next j
            
            aWork(z, KeepCols + 1) = aSrc(1, k + KeepCols) 'month name
            aWork(z, KeepCols + 2) = aSrc(i, k + KeepCols) 'qty
        
        Else
            aWork(z, 1) = i - 1 'primary key
            For j = 1 To KeepCols
                aWork(z, j + 1) = aSrc(i, j) 'add 1 to J to offset from primary key
            Next j
            
            aWork(z, KeepCols + 1 + 1) = aSrc(1, k + KeepCols) 'month name
            aWork(z, KeepCols + 2 + 1) = aSrc(i, k + KeepCols) 'qty
        
        End If
        z = z + 1
    Next k
Next i

aRngSplit = Split(outputDest, "!")
If PrimaryKey = "n" Then
    Range(Selection.Cells(1, 1), Selection.Cells(1, CLng(KeepCols))).Copy Sheets(aRngSplit(0)).Range(aRngSplit(1))
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(0, KeepCols) = "Month"
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(0, KeepCols + 1) = "Value"
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(1, 0).Resize(z - 1, KeepCols + 2) = aWork
Else
    Range(Selection.Cells(1, 1), Selection.Cells(1, CLng(KeepCols))).Copy Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(0, 1)
    Sheets(aRngSplit(0)).Range(aRngSplit(1)) = "Primary Key"
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(0, KeepCols + 1) = "Month"
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(0, KeepCols + 2) = "Value"
    Sheets(aRngSplit(0)).Range(aRngSplit(1)).Offset(1, 0).Resize(z - 1, KeepCols + 2 + 1) = aWork
End If

Beep
End Sub

 

[levanoj]

well there will always be a value in column A but if there's no value in the adjacent column B then the rest of the row will be blank so like you said, there won't be empty cells then more data as you scroll to the right.
I think that's what you were asking, correct?

 

[ChrisM]

You may have to adapt this a bit, it was made for tables of data with various categories, and months in the header row stretching out to the right (where you have UserIDs)

 

[kpark91]

Here's the adaptation which is simpler:
Try

Sub TransposeData()
    Dim rowACount As Double, colRCount As Double, i As Double, j As Double
    Dim RCount2 As Double, LR1 As Double, LC1 As Double
    
    RCount2 = 2
    'Copy Header
    Sheet2.Range("A1").Value = Sheet1.Range("A1").Value
    Sheet2.Range("B1").Value = Sheet1.Range("B1").Value
    
    LR1 = Sheet1.Range("A" & Rows.count).End(xlUp).Row
    
    For i = 2 To LR1
        LC1 = Sheet1.Cells(i, Columns.count).End(xlToLeft).Column
        If LC1 = 1 Then LC1 = LC1 + 1
        For j = 2 To LC1
            Sheet2.Cells(RCount2, 1).Value = Sheet1.Range("A" & i).Value
            Sheet2.Cells(RCount2, 2).Value = Sheet1.Cells(i, j).Value
            RCount2 = RCount2 + 1
        Next j
    Next i
    
End Sub

Put this in your ThisWorkbook module.

 

[kpark91]

If it takes too long to run, try adding in the front of the code

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

and this at the end of the code

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

 

[levanoj]

Hey Kpark

I tried running your code and got a Run-time error '424': Object Required. When I click on debug I get the following line highlighted:

Sheet2.Range("A1").Value = Sheet1.Range("A1").Value

Any advice?

 

[levanoj]

Hi ChrisM

I get the following erro when I run your code: Run-time error '13': type mismatch

When I debug I see the following line highlighted:

aSrc = Selection

Any advice?

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG27May38
[COLOR="Navy"]Dim[/COLOR] rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
[COLOR="Navy"]Set[/COLOR] rng = .UsedRange.Offset(1, 1).Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count - 1)
[COLOR="Navy"]End[/COLOR] With
ReDim Ray(1 To UsedRange.Count, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] rng
    [COLOR="Navy"]If[/COLOR] Dn.column = 2 [COLOR="Navy"]Then[/COLOR] temp = Dn.Offset(, -1)
    [COLOR="Navy"]If[/COLOR] Dn.column = 2 Or Dn <> "" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
         Ray(c, 1) = temp: Ray(c, 2) = Dn
       [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]Next[/COLOR] Dn
Sheets("Sheet2").Range("A2").Resize(c, 2) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick