Re: Transpose data with key in the first column, merge dupes and write to other shee
Please check how fast my code is working on 300,000 rows. My code presumes that in your data the first row is a header row. The output happens in Sheet2, but you can modify this to fit your actual sheet name. I also assumed that for each item you have 3 rows as you indicated in your sample and that the first column is column A. You can test it first on the attachment and see that it works fine.
Option Explicit
Sub ArrangeData()
'Loads the data table into arrInput and the quantities into arrQTY.
'Then arrOutput is being loaded by arrInput and arrQTY with the correct values to be extracted into _
'the output table in the following way:
' arrOutput(1,WriteRow) = ITEM
' arrOutput(2,WriteRow) = DESC
' arrOutput(3,WriteRow) = RM1
' arrOutput(4,WriteRow) = QTY1
' arrOutput(5,WriteRow) = RM2
' arrOutput(6,WriteRow) = QTY2
' arrOutput(7,WriteRow) = RM3
' arrOutput(8,WriteRow) = QTY3
Dim LastRow As Long
Dim arrInput As Variant 'Input Array (ITEM, DESC, RM1 - RM3)
Dim arrQTY As Variant 'QTY Input Array (QTY1 - QTY3)
Dim arrOutput() As Variant 'Output Array
Dim iQTY As Long
Dim WriteRow As Long
Dim WriteCol As Integer
Dim iRow As Long
Dim RmRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
arrInput = Range("A2:C" & LastRow)
arrQTY = Range("K2:K" & LastRow)
iQTY = 1
WriteRow = 1
For iRow = 1 To UBound(arrInput, 1)
'Running through the Item rows
ReDim Preserve arrOutput(1 To 8, WriteRow)
arrOutput(1, WriteRow) = arrInput(iRow, 1) 'ITEM (Col A)
arrOutput(2, WriteRow) = arrInput(iRow, 2) 'DESC (Col B)
WriteCol = 3
For RmRow = iRow To iRow + 2
'Running through the 3 RM's (in column C) of the same ITEM
arrOutput(WriteCol, WriteRow) = arrInput(RmRow, 3) 'RM1 to RM3 (Col C)
WriteCol = WriteCol + 1
arrOutput(WriteCol, WriteRow) = arrQTY(iQTY, 1) 'QTY1 to QTY3 (Col K)
WriteCol = WriteCol + 1
iQTY = iQTY + 1
Next RmRow
iRow = iRow + 2 'Skipping 2 repeating rows of ITEM+DESC
WriteRow = WriteRow + 1
Next iRow
With Sheets("Sheet2")
.Range("A1:H" & UBound(arrOutput, 2) + 1).Value = Application.WorksheetFunction.Transpose(arrOutput)
.Range("A1:H1").Value = Array("ITEM", "DESC", "RM1", "QTY1", "RM2", "QTY2", "RM3", "QTY3") 'Headers
End With
End Sub
Display More
forum.ozgrid.com/index.php?attachment/45784/
