Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Macro To Transpose Data

Posted on 2011-02-24
7
Medium Priority
?
600 Views
Last Modified: 2012-06-27
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
0
Comment
Question by:Brad Sims, CCNA
7 Comments
 
LVL 24

Expert Comment

by:StephenJR
ID: 34970376
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

0
 
LVL 11

Accepted Solution

by:
thydzik earned 2000 total points
ID: 34970457
see the attached.

run the sub runme
Example-with-solution.xlsm
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34970499
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
0
Visualize your virtual and backup environments

Create well-organized and polished visualizations of your virtual and backup environments when planning VMware vSphere, Microsoft Hyper-V or Veeam deployments. It helps you to gain better visibility and valuable business insights.

 
LVL 19

Expert Comment

by:Arno Koster
ID: 34970554
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

0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 34971734
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.
0
 
LVL 24

Expert Comment

by:StephenJR
ID: 34971752
Probably because you had a blank row.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 34971774
John15-16: Ah Ok... Try this

Add this line

ExitLoop = False

before

Do While ExitLoop = False

and try again.

Sid
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article helps those who get the 0xc004d307 error when trying to rearm (reset the license) Office 2013 in a Virtual Desktop Infrastructure (VDI) and/or those trying to prep the master image for Microsoft Key Management (KMS) activation. (i.e.- C…
We live in a world of interfaces like the one in the title picture. VBA also allows to use interfaces which offers a lot of possibilities. This article describes how to use interfaces in VBA and how to work around their bugs.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

886 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question