CODEWITHSUNDEEP
vbaexcel
L. Suarez
L. Suarez

Reputation: 23

Taking rows of data and converting into columns with consecutive rows

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.

Upvotes: 1

Views: 825

Answers (2)

Doug Glancy
Doug Glancy

Reputation: 27488

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

Upvotes: 0

Alex
Alex

Reputation: 1642

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

Upvotes: 1

Related Questions