Solved

Macro To Transpose Data

Posted on 2011-02-24
7
593 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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 500 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
[Live Webinar] The Cloud Skills Gap

As Cloud technologies come of age, business leaders grapple with the impact it has on their team's skills and the gap associated with the use of a cloud platform.

Join experts from 451 Research and Concerto Cloud Services on July 27th where we will examine fact and fiction.

 
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

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

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

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…

632 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