Group and Transpose Columns

[carleo]

How do I transpose as shown below?
I have to columns of data, Site number and Disc number. I have sorted by unique site number but I don't know how to transpose the data.

testing.xls
	A	B	C	D	E	F
1	Site	Disc
2	101	23
3	101	24
4	101	222
5	103	111
6	109	125
7	109	126
8	109	129
9	109	189
10	109	222
11
12
13	Site	Disc1	Disc2	Disc3	Disc4	Disc5
14	101	23	24	222
15	103	111
16	109	125	126	129	189	222
Sheet1

 

[PaddyD]

hi.

see the example:

Book3
	A	B	C	D	E	F
1	Site	Disc
2	101	23
3	101	24
4	101	222
5	103	111
6	109	125
7	109	126
8	109	129
9	109	189
10	109	222
11
12
13	Site	1	2	3	4	5
14	101	23	24	222
15	103	111
16	109	125	126	129	189	222
Sheet1

formula is:

=IF(COUNTIF($A$2:$A$10,$A14)>=B$13,INDEX($A$2:$B$10,SMALL(IF($A$2:$A$10=$A14,ROW($A$2:$A$10)-ROW($A$2)+1,ROW($A$10)+1),B$13),2),"")

...which needs to be array entered using control + shift + enter, nbot just enter. method based on arbitrary lookup example from Chip:

http://www.cpearson.com/excel/lookups.htm

 

[carleo]

Thank you very much PaddyD!

 

[carleo]

PaddyD, How would I put this formula in a macro if the variables will change?

=IF(COUNTIF($A$2:$A$10,$A14)>=B$13,INDEX($A$2:$B$10,SMALL(IF($A$2:$A$10=$A14,ROW($A$2:$A$10)-ROW($A$2)+1,ROW($A$10)+1),B$13),2),"")

Thanks,
Carleo

 

[Tom Urtis]

If you want to do this with a macro, and your source data is always A2:B10, and you want to reorganize it starting in row 14 (with row 13 being headers), see if this comes close to what you want:

Sub Test1()
Application.ScreenUpdating = False
Range("13:65536").ClearContents
Dim w As Integer, x As Long, y As Range, z As Range
Set y = Range("A2:A10")
y.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A13"), Unique:=True
For Each z In Range("A13:A" & Cells(Rows.Count, 1).End(xlUp).Row)
w = 2
With y
Dim u, v
Set u = .Find(z.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not u Is Nothing Then
v = u.Address
Do
Cells(z.Row, w).Value = Cells(u.Row, u.Column + 1).Value
w = w + 1
Set u = .FindNext(u)
Loop While Not u Is Nothing And u.Address <> v
End If
End With
Next z
Dim LC As Long, i As Integer
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
i = 1
Range("A13").Value = Range("A1").Value
For Each z In Range(Cells(13, 2), Cells(13, LC))
z.Value = "Disc" & i
i = i + 1
Next z
Application.ScreenUpdating = True
End Sub

 

[carleo]

This is wonderful! But my source data will always change. As soon as new data is received my macro will clear this excel sheet and begin with 2 columns of data. It will always be columns A:B but the last row will vary. Is there a way to sent labels like these?

aFinalRow = Range("A65536").End(x1Up).Row
bFinalRow = Range("A65536").End(x1Up).Row - 3

 

[Cbrine]

This is wonderful! But my source data will always change. As soon as new data is received my macro will clear this excel sheet and begin with 2 columns of data. It will always be columns A:B but the last row will vary. Is there a way to sent labels like these?

aFinalRow = Range("A65536").End(x1Up).Row
bFinalRow = Range("A65536").End(x1Up).Row - 3

I think you are looking for this
bFinalRow = Range("A65536").End(x1Up).offset(-3,0).row

since the syntax on the other one is correct.

 

[Tom Urtis]

But my source data will always change. As soon as new data is received my macro will clear this excel sheet and begin with 2 columns of data. It will always be columns A:B but the last row will vary.

Try this then:


Sub Test2()
Application.ScreenUpdating = False
Dim w As Integer, x As Long, y As Range, z As Range
x = Cells(Rows.Count, 1).End(xlUp).Row
Set y = Range("A2:A" & x)
y.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A" & x + 3), Unique:=True
For Each z In Range("A" & x + 4 & ":A" & Cells(Rows.Count, 1).End(xlUp).Row)
w = 2
With y
Dim u, v
Set u = .Find(z.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not u Is Nothing Then
v = u.Address
Do
Cells(z.Row, w).Value = Cells(u.Row, u.Column + 1).Value
w = w + 1
Set u = .FindNext(u)
Loop While Not u Is Nothing And u.Address <> v
End If
End With
Next z
Dim LC As Long, i As Integer
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
i = 1
Range("A" & x + 3).Value = Range("A1").Value
For Each z In Range(Cells(x + 3, 2), Cells(x + 3, LC))
z.Value = "Disc" & i
i = i + 1
Next z
Application.ScreenUpdating = True
End Sub

 

[carleo]

I tried the following but it gives me a "Run-time error '1004': Application-defined or object-defined error."

Sub Test1 ()
Application.ScreenUpdating = False

FINALROW = Range("A65536").End(x1Up).Row
BFINALROW = Range("A65536").End(x1Up).Offset(-3, 0).Row

Dim w As Integer, x As Long, y As Range, z As Range
Set y = Range("A2:A" & FINALROW)
y.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A" & BFINALROW), Unique:=True
For Each z In Range("A" & BFINALROW & ":A" & Cells(Rows.Count, 1).End(xlUp).Row)
w = 2
With y
Dim u, v
Set u = .Find(z.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not u Is Nothing Then
v = u.Address
Do
Cells(z.Row, w).Value = Cells(u.Row, u.Column + 1).Value
w = w + 1
Set u = .FindNext(u)
Loop While Not u Is Nothing And u.Address <> v
End If
End With
Next z
Dim LC As Long, i As Integer
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
i = 1
Range("A" & BFINALROW).Value = Range("A1").Value
For Each z In Range(Cells(BFINALROW, 2), Cells(BFINALROW, LC))
z.Value = i
i = i + 1
Next z
Application.ScreenUpdating = True
End Sub

 

[Tom Urtis]

You are mixing code from me and someone else. Please try again, with exactly this code which is modified to suit what I think you are asking for:


Sub Test3()
Application.ScreenUpdating = False
Dim w As Integer, x As Long, y As Range, z As Range
x = Cells(Rows.Count, 1).End(xlUp).Row
Range(x + 1 & ":65536").EntireRow.ClearContents
Range("C:IV").EntireColumn.ClearContents
Set y = Range("A2:A" & x)
y.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A" & x + 3), Unique:=True
For Each z In Range("A" & x + 4 & ":A" & Cells(Rows.Count, 1).End(xlUp).Row)
w = 2
With y
Dim u, v
Set u = .Find(z.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not u Is Nothing Then
v = u.Address
Do
Cells(z.Row, w).Value = Cells(u.Row, u.Column + 1).Value
w = w + 1
Set u = .FindNext(u)
Loop While Not u Is Nothing And u.Address <> v
End If
End With
Next z
Dim LC As Long, i As Integer
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
i = 1
Range("A" & x + 3).Value = Range("A1").Value
For Each z In Range(Cells(x + 3, 2), Cells(x + 3, LC))
z.Value = "Disc" & i
i = i + 1
Next z
Application.ScreenUpdating = True
End Sub