Macro to copy and paste (transpose) data from column to row - Scalable

Question

I am looking to create a macro which would allow me to copy and paste data from one column and then transpose that data over 2 columns in the right order

I have recorded a macro while doing the process manually

    Range("G3").Select
    Application.CutCopyMode = False
    Selection.Copy

    Range("G2:G7").Select          '   (The column range I want to copy)
    Application.CutCopyMode = False
    Selection.Copy

    Range("I1").Select                '    (Row where the range of G2:G7) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    Range("H2:H7").Select          '   (The second column range I want to copy)
    Application.CutCopyMode = False
    Selection.Copy

    Range("I2").Select                '   (Second Row where the range of H2:H7) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    Range("H8:H13").Select        '   (The third column range I want to copy)
    Application.CutCopyMode = FalseSelection.Copy

    Range("I3").Select' ( Third Row where the range of H8:H13) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

The problem is that this code only works up to certain number of rows (up till H13 for example), but if I want to this repeat this process up to row H600 (range of H600:H605) and pasting to I31 for example without copying and pasting this code hundreds of times, is there a way I can do this?

This is what I mean by example

Column H
Star
Greenwood
Titon
Humford

converted to

Column I      |    Column J**  
Star          |    Greenwood
titon         |    Humford

Wlecome to SO. You can benefit from reading [How to avoid Select](https://stackoverflow.com/a/10717999/9199828) to optimize your code. — Foxfire And Burns And Burns, Sep 18 '19 at 14:50

score 0 · Answer 1 · answered Sep 18 '19 at 21:32

Here's an alternative to Copy/Paste - using Variant Arrays. This will be much faster for large data sets.

Sub Demo()
    Dim rng As Range
    Dim Src As Variant
    Dim Dst As Variant
    Dim GroupSize As Long
    Dim Groups As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim iDst As Long
    Dim SrcStartRow As Long
    Dim SrcColumn As Long
    Dim DstStartRow As Long
    Dim DstColumn As Long

    ' Set up Parameters
    GroupSize = 2
    SrcStartRow = 2
    SrcColumn = 8 'H
    DstStartRow = 1
    DstColumn = 9 'I

    With ActiveSheet 'or specify a specific sheet
        ' Get Reference to source data
        Set rng = .Range(.Cells(SrcStartRow, SrcColumn), .Cells(.Rows.Count, SrcColumn).End(xlUp))
        ' Account for possibility there is uneven amount of data
        Groups = Application.RoundUp(rng.Rows.Count / GroupSize, 0)
        If rng.Rows.Count <> Groups * GroupSize Then
            Set rng = rng.Resize(Groups * GroupSize, 1)
        End If


        'Copy data to Variant Array
        Src = rng.Value2

        'Size the Destination Array
        ReDim Dst(1 To UBound(Src, 1) / GroupSize, 1 To GroupSize)

        'Loop the Source data and split into Destination Array
        iDst = 0
        For iRow = 1 To UBound(Src, 1) Step GroupSize
            iDst = iDst + 1
            For iCol = 1 To GroupSize
                Dst(iDst, iCol) = Src(iRow + iCol - 1, 1)
            Next
        Next

        ' Move result to sheet
        .Cells(DstStartRow, DstColumn).Resize(UBound(Dst, 1), UBound(Dst, 2)).Value = Dst
    End With
End Sub

Darrell H · Answer 2 · 2019-09-18T21:10:16.290

-1

Before

Well, you are not really transposing, but I would use this method. I start at 2 to leave the first in place, then basically move the next one over and delete all the empty spaces at the end.

Sub MakeTwoColumns()

    Dim x As Long

    For x = 2 To 500 Step 2
        Cells(x, 6) = Cells(x, 5)
        Cells(x, 5).ClearContents
    Next x

    Columns(5).SpecialCells(xlCellTypeBlanks).Delete
    Columns(6).SpecialCells(xlCellTypeBlanks).Delete
End Sub

After

edited Sep 18 '19 at 21:10

answered Sep 18 '19 at 15:44

Darrell H

1,876
1
9
14

Thank you will try this as well. – shevchenko2020 Sep 19 '19 at 16:08

Macro to copy and paste (transpose) data from column to row - Scalable

2 Answers2