Transpose every X rows to columns (Automation)

[griffindor2020]

Hello,

I would like to transpose a range of data (A1 to KJ1) from every second row (row 1, row 3, row 5, until the last row) under one single column (e.g. column C) in the same sheet.

I am having difficulty creating a macro with a loop that will help me do this. I tried following some youtube tutorials online, but it is not working out very well for me.

It says that there is a compile error : argument not optional.

I have thousands of rows to transpose into one single column.

Please see my script below.

 

[JoeMo]

Hello,

I would like to transpose a range of data (A1 to KJ1) from every second row (row 1, row 3, row 5, until the last row) under one single column (e.g. column C) in the same sheet.

I am having difficulty creating a macro with a loop that will help me do this. I tried following some youtube tutorials online, but it is not working out very well for me.

It says that there is a compile error : argument not optional.

I have thousands of rows to transpose into one single column.

Please see my script below.

If you want the transposed data placed in col C of the same sheet it will have to start below the thousands of rows of raw data in A1:KJ###. Is that really what you want to do?

 

[griffindor2020]

If you want the transposed data placed in col C of the same sheet it will have to start below the thousands of rows of raw data in A1:KJ###. Is that really what you want to do?

Hello,

I made a mistake in my post, I did not want to transpose the data in column C. I would like to transpose in the same sheet but past KJ so that no data is being cut off.

I could do it in another sheet as well.

 

[griffindor2020]

By the way here is my updated macro script.

Sub Transpose_Data_Macro_Loop()
'
' Transpose_Data_Macro_Loop Macro
'
' Keyboard Shortcut: Ctrl+Shift+O
'
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("KN1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Do Until IsEmpty(ActiveCell)

Application.CutCopyMode = False
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("KN297").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Loop

End Sub

 

[Fluff]

How many rows do you have in your data?
Also if you have blanks cells should they be ignored, or included?

 

[JoeMo]

Hello,

I made a mistake in my post, I did not want to transpose the data in column C. I would like to transpose in the same sheet but past KJ so that no data is being cut off.

I could do it in another sheet as well.

Assuming you want to transpose the data as values, no formulas involved, and column KK is empty to accept the transposed values, try this:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    If i Mod 2 <> 0 Then
        Vrw = R.Rows(i).Value
        Vout = Application.Transpose(Vrw)
        NxRw = IIf(IsEmpty(Range("KK1")), 1, Range("KK" & Rows.Count).End(xlUp).Row + 1)
        Range("KK" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

I forgot to add, if you have more than approximately 7500 rows of data across A:KJ, the transposed data will not all fit on one column which can hold only 2^20 (1,048,576) data elements. The code I posted assumes you have fewer than 7500 rows of raw data and you only want to transpose every other row.

 

[griffindor2020]

Assuming you want to transpose the data as values, no formulas involved, and column KK is empty to accept the transposed values, try this:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    If i Mod 2 <> 0 Then
        Vrw = R.Rows(i).Value
        Vout = Application.Transpose(Vrw)
        NxRw = IIf(IsEmpty(Range("KK1")), 1, Range("KK" & Rows.Count).End(xlUp).Row + 1)
        Range("KK" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
    End If
Next i
Application.ScreenUpdating = True
End Sub

Hello !

That worked fantastic for the first set of rows ! I will definitely save this script :D !

Now I was wondering how do I get the second batch of rows to do the same thing ? i.e. instead of row 1,3,5 etc... I would like to apply the same script on row 2,4,6 etc...?

Thank you so much

 

[griffindor2020]

How many rows do you have in your data?
Also if you have blanks cells should they be ignored, or included?

Hello,

Thank you for your question. I have 1780 rows in my data. Blank cells should be ignored.

I hope to hear from you soon

 

[JoeMo]

Hello !

That worked fantastic for the first set of rows ! I will definitely save this script :D !

Now I was wondering how do I get the second batch of rows to do the same thing ? i.e. instead of row 1,3,5 etc... I would like to apply the same script on row 2,4,6 etc...?

Thank you so much

For the even row numbers change this:

If i Mod 2 <> 0 Then
to this:

If i Mod 2 = 0 Then

If you would like to put the even rows in the column following the odd rows, change this

Range("KK" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout

to this:

Range("KL" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout

As is, the code does not ignore blank cells but they can be removed like this:

Sub DataTranspose()
Dim R As Range, Vin As Variant, Vrw As Variant, Vout As Variant, i As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To 1)
Application.ScreenUpdating = False
For i = 1 To UBound(Vin, 1)
    If i Mod 2 <> 0 Then
        Vrw = R.Rows(i).Value
        Vout = Application.Transpose(Vrw)
        NxRw = IIf(IsEmpty(Range("KK1")), 1, Range("KK" & Rows.Count).End(xlUp).Row + 1)
        Range("KK" & NxRw).Resize(UBound(Vrw, 2), 1).Value = Vout
    End If
Next i
With Columns("KK")
    On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    On Error GoTo 0
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub