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

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

Answer 1

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

Answer 2

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