Taking rows of data and converting into columns with consecutive rows - vba

Question

I've seen some similar posts but not quite what I need or could understand to solve my simple problem.
I have hundreds of rows of data that I'd like to transform into columns. Original data is like so with two empty rows between and the sets of related data can vary in length:
9
8
7
6
5
4
3
2
1
J
I
H
G
F
E
D
C
B
A
I'd like to be able to reverse the order of each set and then transpose them in columns going down another row for each data set like so:
1 2 3 4 5 6 7 8 9
A B C D E F G H I J
I had some success with the first part using a simple formula =OFFSET($A$2,COUNTA(A:A)-ROW(),0) because I wasn't sure how to do it in VBA.
The code I'm using to grab all the data and then transpose, I'm having trouble getting it to go down a row for each unique data set. Here's the code I'm trying to use, but it doesn't seem to work and just start running down the worksheet until the macro craps out.
Sub TransposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheets("Output").Range("A3:A10002")
Set OutRange = Sheets("Output").Range("H2:NTR2")
For i = 1 To 10000 Step 1
OutRange.Cells(1, i) = InRange.Cells(i, 1)
ActiveCell.Offset(1, 0).Select
Next i
End Sub
I'm sure there's something obvious and simple I'm missing but alas I'm still a noob in training. Any suggestions would be greatly appreciated.

Answer 1

Assuming your data is at column A, please try the following using sort then pastespecial with transpose: (please change sheets name according to your own)
Sub sortNtranspose()
Dim r As Integer
Dim i As Integer
Dim j As Integer
Dim rn As Range
r = Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To r
Set rn = Range(Cells(i, 1), Cells(Cells(i, 1).End(xlDown).Row, 1))
rn.Sort key1:=Cells(i, 1), order1:=xlAscending, Header:=xlNo
Set rn = Range(Cells(i + 1, 1), Cells(Cells(i, 1).End(xlDown).Row, 1))
rn.Copy
Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Do While Not IsEmpty(Cells(i, 1))
If IsEmpty(Cells(i, 2)) Then
Cells(i, 2).EntireRow.Delete
Else:
i = i + 1
End If
Loop
r = Sheets("Sheet1").UsedRange.Rows.Count
If j >= r Then
Exit Sub
End If
j = Cells(i, 1).End(xlDown).Row
i = j - 1
Next i
End Sub

Answer 2

This code assumes that your data are constants, and uses VBA's wonderful SpecialCells property to break out each chunk in column 1. It also uses an array, which is much faster than looping through cells:
Sub TransposeColumnSections()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim ColumnConstants As Excel.Range
Dim i As Long
Dim ColumnArea As Excel.Range
Dim AreaRowsCount As Long
Dim ReversedConstants() As Variant
Dim j As Long
Set ws = ActiveSheet
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set ColumnConstants = .Columns(1).SpecialCells(xlCellTypeConstants)
For i = 1 To ColumnConstants.Areas.Count
Set ColumnArea = ColumnConstants.Areas(i)
AreaRowsCount = ColumnArea.Rows.Count
ReDim ReversedConstants(1 To AreaRowsCount)
For j = AreaRowsCount To 1 Step -1
ReversedConstants(AreaRowsCount - (j - 1)) = ColumnArea(j).Value
Next j
.Cells(i, 2).Resize(1, AreaRowsCount) = ReversedConstants
Next i
.Columns(1).Delete
End With
End Sub