Solved

# Macro To Transpose Data

Posted on 2011-02-24
580 Views
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
Question by:John15-16

LVL 24

Expert Comment

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)
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
``````
0

LVL 11

Accepted Solution

thydzik earned 500 total points
see the attached.

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

LVL 30

Expert Comment

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)

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
ws2.Cells(i, c).Value = aCell.Offset(, 3).Value
c = c + 1
Else
ExitLoop = True
End If
Loop
End If
Next i
End Sub
``````
Copy-of-Example.xlsm
0

LVL 19

Expert Comment

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
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
``````
0

LVL 7

Author Comment

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

Probably because you had a blank row.
0

LVL 30

Expert Comment

John15-16: Ah Ok... Try this

ExitLoop = False

before

Do While ExitLoop = False

and try again.

Sid
0

## Featured Post

Recently Microsoft released a brand new function called CONCAT. It's supposed to replace its predecessor CONCATENATE. But how does it work? And what's new? In this article, we take a closer look at all of this - we even included an exercise file for…
In this article we discuss how to recover the missing Outlook 2011 for Mac data like Emails and Contacts manually.
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 create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.