Macro To Transpose Data

I have attached a sample file of the results I want.  Original Data is on Sheet 1 - Transposed Data is on Sheet 2.

What I am looking for is a macro that will find all rows of the same LOT# and transpose the data to one row. Once the data is transposed for that lot it should delete the remaining rows and move the next LOT#.

There are over 200,000 rows on my original sheet, so this is just a sample.  Also, the number of rows per LOT can vary.  Some only have 2 rows, some 3, and some 5.  
Brad Sims, CCNANetwork AdministratorAsked:
Who is Participating?
thydzikConnect With a Mentor Commented:
see the attached.

run the sub runme
Here is one approach:
Sub Macro1()

Dim vIn, oDic As Object, vOut(), i As Long, j As Long

Application.ScreenUpdating = False

vIn = Sheet1.Range("A1").CurrentRegion.Value
ReDim vOut(1 To UBound(vIn, 1), 1 To 5)
Set oDic = CreateObject("Scripting.Dictionary")

With oDic
    For i = 1 To UBound(vIn, 1)
        If Not .Exists(vIn(i, 1)) Then
            j = j + 1
            vOut(j, 1) = vIn(i, 1)
            vOut(j, 2) = vIn(i, 2)
            vOut(j, 3) = vIn(i, 3)
            vOut(j, 4) = vIn(i, 4)
            vOut(j, 5) = vIn(i, 5)
            .Add vIn(i, 1), j
        ElseIf .Exists(vIn(i, 1)) Then
            vOut(.Item(vIn(i, 1)), 5) = vOut(.Item(vIn(i, 1)), 5) & "," & vIn(i, 5)
        End If
    Next i
End With

With Sheet2
    .Range("A1").Resize(j, 5) = vOut
    .Columns("E:E").TextToColumns Destination:=.Range("E1"), DataType:=xlDelimited, Comma:=True
End With

Application.ScreenUpdating = True

End Sub

Open in new window

Another way using .Find()

sample Attached.


Code Used

Private Sub CommandButton1_Click()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim ws2lastRow As Long
    Dim SearchString As String
    Dim aCell As Range, bCell As Range
    Dim ExitLoop As Boolean
    Dim i As Long, c As Long
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    ws1.Columns(2).Copy ws2.Columns(2)
    ws2.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo
    ws2lastRow = ws2.Range("B" & Rows.Count).End(xlUp).Row
    For i = 2 To ws2lastRow
        SearchString = ws2.Range("B" & i).Value
        Set aCell = ws1.Columns(2).Find(What:=SearchString, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        c = 5
        If Not aCell Is Nothing Then
            Set bCell = aCell
            ws2.Cells(i, c).Value = aCell.Offset(, 3).Value
            ws2.Cells(i, 1).Value = aCell.Offset(, -1).Value
            ws2.Cells(i, 3).Value = aCell.Offset(, 1).Value
            ws2.Cells(i, 4).Value = aCell.Offset(, 2).Value
            c = c + 1
            Do While ExitLoop = False
                Set aCell = ws1.Columns(2).FindNext(After:=aCell)
                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do
                    ws2.Cells(i, c).Value = aCell.Offset(, 3).Value
                    c = c + 1
                    ExitLoop = True
                End If
        End If
    Next i
End Sub

Open in new window

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Arno KosterCommented:
you can use this code, pasted in the vba page of sheet 1
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lot As String
Dim id As String
Dim created As String
Dim transit As String
Dim equipment As String

    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Cancel = True
        lot = Range("A" & Target.Row)
        For Each Row In UsedRange.Rows
            If Row.Cells(1).Text = lot Then
                '-- process data
                id = Range("B" & Row.Row)
                created = Range("C" & Row.Row)
                transit = Range("D" & Row.Row)
                equipment = Range("E" & Row.Row)
                '-- find existing information
                Set result = Worksheets("sheet2").UsedRange.Find(lot, LookIn:=xlValues)
                If result Is Nothing Then
                    '-- add new entry
                    pos = Worksheets("sheet2").UsedRange.Rows.Count + 1
                    Worksheets("sheet2").Range("A" & pos) = lot
                    Worksheets("sheet2").Range("B" & pos) = id
                    Worksheets("sheet2").Range("C" & pos) = created
                    Worksheets("sheet2").Range("D" & pos) = transit
                    Worksheets("sheet2").Range("E" & pos) = equipment
                    '-- append to existing entry
                    pos = result.Row
                    '-- find an empty cell
                    col = 5
                    While Worksheets("sheet2").Rows(pos).Cells(col) <> ""
                        col = col + 1
                    '-- paste data
                    Worksheets("sheet2").Cells(pos, col) = equipment
                End If
                '-- remove original data
            End If
        Next Row
    End If

End Sub

Open in new window

Brad Sims, CCNANetwork AdministratorAuthor Commented:
Thank you all for your suggestions.  

StephenJR, your code worked for 1/2 of the spreadsheet, but for some reason stopped in the middle of the sheet.  I verified there were no empty rows, and even tried sorting by LOT#.

Sid, your code was working but kept looping back.  I ended up having to CTRL - Break to get it to stop running after a few minutes.  I even added the "Application.ScreenUpdating=False" at the beginning and set it back to true and tried again with no luck.
Probably because you had a blank row.
John15-16: Ah Ok... Try this

Add this line

ExitLoop = False


Do While ExitLoop = False

and try again.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.