Transposing Data

[timculberson]

I posted this question a little earlier, but had a hard time explaining what I was trying to do. I need some vba to transpose repeating "blocks" of data as follows:

Existing Data:

1 | A
2 | B
3 | C
1 | D
2 | E
3 | F
4 | G
1 | H
2 | I
3 | J
5 | K
1 | L
2 | M
3 | N

I want it to transpose as:

1 | 2 | 3 | 4 | 5
A | B | C
D | E | F | G
H | I | J | blank | K
L | M | N

In other words, the common denominator in each resulting row of data is that it always starts with column a being a "1" in the original data.

Thanks for any help!

[Regouin]

so you want the spots to be blank when no data is found in that particular set, and every new set always starts with 1?


and another quick question, are there just 5 different numbers or do you have an awful lot of them (say 100 instead of 5) cos then it might be worth automising the project by using the R1C1converter in the kb.

[timculberson]

well, actually, each new set always starts with the word "type", but yes essentially what you have said, with some data "sets" potentially having new headings that need to be added as new column headings when encountered.

[Regouin]

The way i am thinking now is the following, make a listbox on your sheet, and with a "find" let it search all the 'type' in the list and insert the row numbers into the list, the you can set the range (a1 to a3 ie) and then for each one let them check in the range if the giving name is there, else add it to it and insert the data in the appropriate row under it. But this might be a bit farfetched. When I get the time I might try to write it out.

[timculberson]

I would appreciate any help....I've been working on this problem for quite some time now)

[mvidas]

Hi Tim,
Give the following a try, should do exactly as you need!


Sub timculberson()
Dim HeadingCol As Range, ValueCol As Range, HeadingArr, ValueArr
Dim Heads() As String, HeadCt As Long, AllData() As String, DataCt As Long
Dim i As Long, j As Long, iUB As Long, dPos As Long
Set HeadingCol = Columns("A") 'Set entire column for HeadingCol
Set ValueCol = Columns("B") 'Set entire column for HeadingCol
'Re-set HeadingCol and ValueCol variables to be only in used range
Set HeadingCol = Intersect(HeadingCol, HeadingCol.Parent.UsedRange)
Set ValueCol = Intersect(ValueCol, HeadingCol.EntireRow)
If HeadingCol Is Nothing Or ValueCol Is Nothing Then Exit Sub
HeadingArr = HeadingCol.Value
ValueArr = ValueCol.Value
'Initialize heading array, and populate with unique heading ValueCol
HeadCt = 0
ReDim Heads(0)
iUB = UBound(HeadingArr, 1)
For i = 1 To iUB
If HeadingArr(i, 1) <> "" Then
If InSArr(Heads, HeadingArr(i, 1)) = -1 Then
ReDim Preserve Heads(HeadCt)
Heads(HeadCt) = HeadingArr(i, 1)
HeadCt = HeadCt + 1
End If
End If
Next 'CLL
HeadCt = HeadCt - 1
'Enter headings into AllData array
DataCt = 0
ReDim AllData(HeadCt, DataCt)
For i = 0 To HeadCt
AllData(i, 0) = Heads(i)
Next i
'populate alldata array
For i = 1 To iUB
dPos = InSArr(Heads, HeadingArr(i, 1))
If dPos = 0 Then
DataCt = DataCt + 1
ReDim Preserve AllData(HeadCt, DataCt)
End If
If dPos <> -1 Then AllData(dPos, DataCt) = ValueArr(i, 1)
Next 'i
'transfer alldata array contents back to excel
Application.ScreenUpdating = False
Sheets.Add
For i = 0 To HeadCt
For j = 0 To DataCt
Range("A1").Offset(j, i) = AllData(i, j)
Next 'j
Next 'i
Application.ScreenUpdating = True
End Sub

Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next 'i
InSArr = -1
End Function

Currently I have it putting the data into a new sheet, if you dont want this, change the "Sheets.Add" in the last block to "cells.clear" or whatever you want to do to clear the output area, and then change the Range("A1") to wherever your initial starting cell is.

If you have any questions, don't hesitate to ask!
Matt

[Regouin]

Thats a better solution then the one i am working out :) works to a certain extend though, but still

[timculberson]

Beautiful!

It worked perfectly...thanks so much Matt!

[mvidas]

Glad to help! The only thing that could go wrong with it is that it treats the first non-blank cell in the HeadingCol range as your 'key' header, represented by "1" and "type" above in the question. If you had something abstract as your first header that isn't repeated ever again, everything else would stay in one row.
If you think your headingcol column might have an actual column header to begin with, change the first intersect statement to include 'rows("2:65536")' (substituting the 2 for whatever your first data row would be).
The above would be unlikely, though it is possible.
Let me know if it needs any tweaking!
Matt

[byundt]

Tim,
I appreciate that the problem has already been solved--but it is also possible to do so without VBA using a helper column and a regular formula.

Assuming that your key number and data are in columns A and B, then put the following formula in helper column C:

=COUNTIF(C$1:C1,1)

Copy this formula down
This formula returns the row number of the transposed data, and uses the 1 as the value that triggers a change to a new row.

Then, assuming that your key values are listed across the top of row 1 in F1 to J1, put the following formula in cell F2:

=IF(SUMPRODUCT(($A$1:$A$100=F$1)*($C$1:$C$100=ROW()-1)), INDEX($B:$B,SUMPRODUCT(($A$1:$A$100=F$1)*($C$1:$C$100=ROW()-1)*ROW($A$1:$A$100))),"")
Copy this both across and down. It will return an empty string "" if there is no matching value for that cell. The reference to row 100 in this formula is arbitrary--it may extend beyond your data.

Brad