asked on

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.
Example.xlsx

StephenJR

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

ASKER CERTIFIED SOLUTION

Travis Hydzik

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SiddharthRout

Another way using .Find()

sample Attached.

Sid

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
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
End Sub

Open in new window

Copy-of-Example.xlsm

Arno Koster

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
            Row.Select
            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
                Else
                    '-- append to existing entry
                    pos = result.Row
                    '-- find an empty cell
                    col = 5
                    While Worksheets("sheet2").Rows(pos).Cells(col) <> ""
                        col = col + 1
                    Wend
                    '-- paste data
                    Worksheets("sheet2").Cells(pos, col) = equipment
                End If
                
                '-- remove original data
                Row.Clear
            End If
        Next Row
    End If

End Sub

Open in new window

Brad Sims

ASKER

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.

StephenJR

Probably because you had a blank row.

SiddharthRout

John15-16: Ah Ok... Try this

Add this line

ExitLoop = False

before

Do While ExitLoop = False

and try again.

Sid