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