Transpose Macro Needed (willing to donate to charity for quick answer!)

[Dazzawm]

I have sheet 1 with 2 columns, a number in A and a transmission in column B. I need the number and the transmission transposed onto sheet 2. There may be a unique number in A or several the same with different transmissions in B. In the example I have highlighted the duplicates in A. The yellow one has the same number in A but 3 transmissions in B so they will go under the transmission header in B (also yellow), the same with blue and orange.

Sheet A will consist of several hundred thousand rows so this is just a small example. Like I mentioned I would appreciate a quick solution on this one as it is for work so willing to donate to charity if needs be. Thanks.

Excel 2010
	A	B
1	Number	Transmission
2	10200362	MTM
3	10200363	MTM
4	10200364	MTM
5	10200364	ATM
6	10200364	CVT
7	10200365	MTM
8	10200365	ATM
9	10200366	MTM
10	10200371	MTM
11	10200371	SEMI
12	10200372	ATM
13	10200373	ATM
Sheet1

Sheet 2 after code.

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	ATM	ATM & CVT	ATM & CVT & MTM	ATM & CVT & MTM & Semi	ATM & CVT & Semi	ATM & MTM	ATM & MTM & Semi	ATM & Semi	CVT	CVT & MTM	CVT & MTM & Semi	CVT & Semi	MTM	MTM & Semi	Semi	Direct
2	10200372		10200364			10200365							10200362	10200371
3	10200373												10200363
Sheet2

 

[Special-K99]

What are the range of values that column B will cover?
We already have

MTM
CVT
ATM
Semi

It looks like there's a Direct too.
Will there be others as well or is that the complete range of values?

 

[Dazzawm]

Yes those 4 plus Direct, I think I put all the possible combinations in sheet 2. (Direct will always be on its own)

 

[Special-K99]

I'll have a think, this may take some time, looks a little tricky.

 

[Dazzawm]

Thanks.

 

[wideboydixon]

Is Sheet2 already set up or should the macro add it? I have a solution that creates it from scratch ...

WBD

 

[Dazzawm]

Ideally it would be added by the macro

 

[wideboydixon]

OK. Give this a whirl:

Public Sub TransposeTransmissions()

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow As Long
Dim nextCol As Long
Dim newSheet As Worksheet
Dim thisSheet As Worksheet
Dim transmissions As Collection
Dim lastNumber As String
Dim columnHeader As String
Dim foundColumn
Dim i As Long

' Turn of screen updating
Application.ScreenUpdating = False

' Set up the first sheet and find the last row
Set thisSheet = ActiveSheet ' or Set thisSheet = Sheets("Sheet1")
lastRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row + 1

' Set up the second sheet
Set newSheet = Sheets.Add(After:=thisSheet) ' or Set newSheet = Sheets("Sheet2")

' Loop through all data
lastNumber = ""
nextCol = 1
For thisRow = 2 To lastRow
    ' Change of number?
    If thisSheet.Cells(thisRow, "A").Value <> lastNumber Then
        If lastNumber <> "" Then
            ' Something to put in the second sheet - create the column header
            columnHeader = ""
            For i = 1 To transmissions.Count
                columnHeader = columnHeader & " & " & transmissions(i)
            Next i
            columnHeader = Mid(columnHeader, 4)
            
            ' Look for this column
            foundColumn = Application.Match(columnHeader, newSheet.Range("1:1"), 0)
            
            ' Add a new column if we didn't find it
            If IsError(foundColumn) Then
                newSheet.Cells(1, nextCol).Value = columnHeader
                newSheet.Cells(2, nextCol).Value = lastNumber
                nextCol = nextCol + 1
            Else
                ' Find the last row in the found column and add the number there
                nextRow = newSheet.Cells(newSheet.Rows.Count, foundColumn).End(xlUp).Row + 1
                newSheet.Cells(nextRow, foundColumn).Value = lastNumber
            End If
        End If
        
        ' Remember this number and create a new collection of transmissions
        lastNumber = thisSheet.Cells(thisRow, "A").Value
        Set transmissions = New Collection
    End If
    
    ' Add this transmission to the collection
    InsertTransmission transmissions, thisSheet.Cells(thisRow, "B").Value
Next thisRow

' Turn on screen updating
Application.ScreenUpdating = True

End Sub
Private Sub InsertTransmission(transmissions As Collection, transmission As String)

Dim i As Long

' If the collection is empty then just add it
If transmissions.Count = 0 Then
    transmissions.Add Item:=transmission
    Exit Sub
End If

' Put it in the right place
For i = 1 To transmissions.Count
    If transmission < transmissions(i) Then
        transmissions.Add Item:=transmission, Before:=i
        Exit For
    End If
Next i

' If we didn't find a place for it then put it at the end
If i > transmissions.Count Then transmissions.Add Item:=transmission

End Sub

That should create the new sheet and populate the columns. When done, you might need to sort the data on the second sheet to put the columns in alphabetical order. Highlight the data and click the Sort button (on the Data ribbon). Click Options... and select "Sort left to right" then click OK. Now select to sort by Row 1 and click OK.

WBD

 

[Dazzawm]

Thanks, I am not sure it is working correct. I am getting results like below and the headers stretch right across to column EA?

Excel 2010
	A	B	C	D	E	F	G
1	CVT	Direct Drive	MTM	MTM & MTM & MTM	MTM & MTM	MTM & MTM & MTM & MTM	MTM & MTM & SEMI & SEMI
2	M10100770000001	M10105420000003	M10200350000001	M10200350000004	M10200350000005	M10200370000001	M10200370000005
3	M10100900000001	M10105420000006	M10200350000002	M10200360000004	M10200360000002	M10200370000003	M10200400000008
4	M10100900000002	M10105420000007	M10200350000003	M10200390000007	M10200360000005	M10200370000004	M10200400000019
5	M10100900000003	M10105420000008	M10200350000006	M10200390000008	M10200370000002	M10200370000008	M10204210000002
Sheet4

 

[wideboydixon]

Oh! Is it possible that M10200350000004 has three entries in the list each one with a transmission of "MTM"? Try this subtle change instead?

Public Sub TransposeTransmissions()

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow As Long
Dim nextCol As Long
Dim newSheet As Worksheet
Dim thisSheet As Worksheet
Dim transmissions As Collection
Dim lastNumber As String
Dim columnHeader As String
Dim foundColumn
Dim i As Long

' Turn of screen updating
Application.ScreenUpdating = False

' Set up the first sheet and find the last row
Set thisSheet = ActiveSheet ' or Set thisSheet = Sheets("Sheet1")
lastRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row + 1

' Set up the second sheet
Set newSheet = Sheets.Add(After:=thisSheet) ' or Set newSheet = Sheets("Sheet2")

' Loop through all data
lastNumber = ""
nextCol = 1
For thisRow = 2 To lastRow
    ' Change of number?
    If thisSheet.Cells(thisRow, "A").Value <> lastNumber Then
        If lastNumber <> "" Then
            ' Something to put in the second sheet - create the column header
            columnHeader = ""
            For i = 1 To transmissions.Count
                columnHeader = columnHeader & " & " & transmissions(i)
            Next i
            columnHeader = Mid(columnHeader, 4)
            
            ' Look for this column
            foundColumn = Application.Match(columnHeader, newSheet.Range("1:1"), 0)
            
            ' Add a new column if we didn't find it
            If IsError(foundColumn) Then
                newSheet.Cells(1, nextCol).Value = columnHeader
                newSheet.Cells(2, nextCol).Value = lastNumber
                nextCol = nextCol + 1
            Else
                ' Find the last row in the found column and add the number there
                nextRow = newSheet.Cells(newSheet.Rows.Count, foundColumn).End(xlUp).Row + 1
                newSheet.Cells(nextRow, foundColumn).Value = lastNumber
            End If
        End If
        
        ' Remember this number and create a new collection of transmissions
        lastNumber = thisSheet.Cells(thisRow, "A").Value
        Set transmissions = New Collection
    End If
    
    ' Add this transmission to the collection
    InsertTransmission transmissions, thisSheet.Cells(thisRow, "B").Value
Next thisRow

' Turn on screen updating
Application.ScreenUpdating = True

End Sub
Private Sub InsertTransmission(transmissions As Collection, transmission As String)

Dim i As Long

' If the collection is empty then just add it
If transmissions.Count = 0 Then
    transmissions.Add Item:=transmission
    Exit Sub
End If

' Put it in the right place
For i = 1 To transmissions.Count
    If transmission < transmissions(i) Then
        transmissions.Add Item:=transmission, Before:=i
        Exit For
    ElseIf transmission = transmissions(i) Then
        i = 1
        Exit For
    End If
Next i

' If we didn't find a place for it then put it at the end
If i > transmissions.Count Then transmissions.Add Item:=transmission

End Sub

WBD