Solved

Macro To Transpose Data

Posted on 2011-02-24
7
584 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
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 19

Expert Comment

by:akoster
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
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

932 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

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now