I'm writing a VBA program which copies and organizes data from one master sheet into numerous other sheets. One of the recipient sheets unifies all the data from the master sheet which holds the same id number into a single row. For this operation, I am looping through the master sheet for each id number, copying each row which holds the current id number into a new sheet purely used for calculations and organizing, and rearranging the data in this sheet into the new row. The resultant row is copied into the recipient sheet. This process of organizing data for every id number takes a long time to process, especially given the very large size of this sheet and the processing time of the other recipient sheets. I'm wondering if there is a better way to organize and copy data without using an intermediate calculation sheet.
The below code is the main sub, which calls another sub OrganizeAndCopyToPal, which organizes the data in the calculation sheet and copies the result into the recipient sheet.
Sub PalletAssemblyLog() Dim allidNum As Range Dim curridNum As Range Dim rowCount As Long Dim idNum Dim I As Long Dim j As Long Dim machineLoc As String Dim calc As Worksheet Dim full As Worksheet Dim pal As Worksheet Set calc = Sheet3 Set full = Sheet4 Set pal = Sheet1 For I = 2 To rowCount idNum = full.Cells(I, 17).Value For j = 2 To rowCount If full.Cells(j, 17).Value = idNum Then If allidNum Is Nothing Then Set allidNum = full.Cells(j, 17) Else Set allidNum = Union(allidNum, full.Cells(j, 17)) End If End If Next j Set curridNum = allidNum.EntireRow calc.Activate calc.Cells.Clear full.Activate curridNum.Copy calc.Range("A1") OrganizeAndCopyToPal curridNum Next I End Sub
The below sub organizes and copies the data for each id number. The final sub to copy the data isn't related to the matter of simplifying this task so I'm not including it.
Sub OrganizeAndCopyToPal(curridNum) Dim calc As Worksheet Dim pal As Worksheet Set calc = Sheet3 Set pal = Sheet1 calc.Activate Dim rowCount As Long rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row Dim palRow As Long palRow = rowCount + 2 Dim partRow As Long partRow = palRow + 2 Dim currPartCount As Range Dim assembly As String Dim id As String Dim location As String Dim machType As String Dim machLoc As String Dim currPart As String Dim link As String Dim tot As Long tot = 0 With calc .Cells(1, 1).Copy .Cells(palRow, 2) assembly = .Cells(1, 1).Value .Cells(1, 2).Copy .Cells(palRow, 5) id = .Cells(1, 17).Value asArray = SplitMultiDelims(id, "|-") 'MsgBox asArray(0) & " " & asArray(1) & " " & asArray(2) machArray = Split(.Cells(1, 8), "-") machType = machArray(0) .Cells(palRow, 3) = machType machLoc = .Cells(1, 8).Value .Cells(palRow, 4) = machLoc .Cells(1, 17).Copy .Cells(palRow, 10) location = Cells(1, 9) .Cells(palRow, 1) = location For I = 1 To rowCount partArray = Split(.Cells(I, 16).Value, ",") For j = 0 To UBound(partArray) partArray2 = Split(partArray(0), "-") partPrefix = partArray2(0) If j = 0 Then currPart = partArray(j) Else currPart = partPrefix & "-" & CStr(partArray(j)) End If tf = 1 For k = 0 To tot If Cells(partRow + k, 1).Value = currPart Then tf = 0 Exit For End If Next k If tf = 1 Then .Cells(partRow + tot, 1).Value = currPart tot = tot + 1 End If Next j Next I For I = 1 To tot Cells(palRow, 10 + I).Value = Cells(partRow + I - 1, 1) Next I End With CopyToPal curridNum, palRow End Sub
Thank you for any tips or help that you can offer.