Best way to copy data to a new sheet and reorganize it (VBA)

Question

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.

Answer 1

Some comments that you hopefully find useful:

1. (Best Practice)Declare "Option Explicit" at the top of every module. This option requires that every variable used in the module is explicitly declared. Doing so avoids numerous errors, not the least of which are new-variables-declared-by-typo which can be hard to spot. Declaring it at the top of the provided code resulted in the need to add 9 declarations.
2. (Best Practice)Explicitly declare types for your variables and parameters. Dim idNum implicitly declares idNum as a Variant. It is probably a Long - but now, to the reader has to look through the code to know for sure. Sub OrganizeAndCopyToPal(curridNum) => parameter curridNum is, by default, declared as a Variant - but it is a Range. Sub OrganizeAndCopyToPal(curridNum As Range) removes all ambiguity.

Naming things.

1. You can change the code name of worksheets (e.g., Sheet3). So there is no need for Dim calc As Worksheet, Set cal = Sheet3. Simply rename Sheet3 to calc in the Properties Window. Now you do not need to declare and assign calc in your code - you can just use it directly as a Worksheet object. Same comment for full and pal.
2. Use meaningful names. Single character names are non-descriptive and (IMO) make code harder to read. Even loop and array index variables are easier to interpret if given names like 'idxRow', 'rowNum', etc. Descriptive names will not slow down your code or take up too much memory. What a descriptive name will do is allow you to avoid lots of re-interpretation time when you want to update this code after a long absence.

Don't Repeat Yourself (DRY) and magic numbers:

1. As an example, PalletAssemblyLog repeats the expression full.Cells(j, 17) 3 times in 5 lines. This expression is both repeated and contains a 'magic number' - 17. 17 must be an important column in the full worksheet...give it a name! (full could use a more descriptive name as well). Private Const idNumberColumn As Long = 17 will not slow down the code, but it is much more readable...and - most importantly, as soon as you need to insert a new column prior to column 17, you only have to change the column number in one location.
2. Sub OrganizeAndCopyToPal(curridNum) uses lots of magic numbers that need a name: 2,5,4,8,10,16. Give them all names and assign them as constant values in one location. You'll thank yourself in the future when the calc worksheet is eventually re-organized.

Single Responsibility Principle (SRP): Each procedure should have a single purpose (or, have a single reason to change)

1. The OrganizeAndCopyToPal procedure by its name, betrays that it does two things: Organizes and Copies. In fact, the passed-in argument curridNum is not used until the end of OrganizeAndCopyToPal when it is a parameter in the expression CopyToPal curridNum, palRow. There is no need to pass curridNum as a parameter because the subroutine does not need to know the curridNum in order to determine the palRow. Calculating palRow is a single responsibility - consider making OrganizeAndCopyToPal a function like 'Function DetermineRowTarget() As Long'.
2. Don't hesitate to break out blocks of code from procedures that can be explained/documented using a function name. Within PalletAssemblyLog, there is a nested loop that gathers all ranges related to the same id number. Rather than sifting through the loop logic to discover what does, it could be better self-documenting by making it a Function that returns palRow. In this case it receives bonus points for a reduction in loop nesting.

Speed

1. Within the main loop, you are activating worksheets multiple times. It is not clear to me that you need to make the various sheets 'Active' for the modification code that you have. Simply reducing/eliminating anything that causes a redraw within a loop will speed things up.
2. It looks as though you are processing the full set of idNum rows every time you increment the idNum. If true, this means you are repeating the operations many, many more times than needed. Change the logic to ensure you only process each idNum once. This should greatly speed up your process. One way to do this is to cache the Range result for each idNum. So, the next time you encounter the idNum, you can skip it. Also, the inner loop should start at the row + 1 of the 'new' idNum. This avoid iterating through previously evaluated rows. The example below uses a Dictionary to cache the Range results. Once all the Ranges for each idNum are determined, it runs though each idNum to Organize as before.
3. During the operations, temporarily turn off screen updating and calculations(if the operation does not depend on the calculations)

Below is the code with some of the edits described above.

    Option Explicit

    Private Const idNumberColumn As Long = 17

    Sub PalletAssemblyLog()

        Dim allidNum As Range
        Dim curridNum As Range
        Dim rowCount As Long
        Dim idNum As Long
        Dim I As Long
        Dim j As Long
        Dim machineLoc As String
        
        'Dictionary requires a reference to the 'Microsoft Scripting Runtime'.  From Tools menu: Tools -> References
        Dim processedIdNumbers As Dictionary
        Set processedIdNumbers = New Dictionary
        
       
        Dim rowIdx As Long
        For rowIdx = 2 To rowCount
            idNum = full.Cells(rowIdx, idNumberColumn).Value
            
            If Not processedIdNumbers.Exists(idNum) Then
                Set curridNum = GetAggregatedRangeForIdNumber(idNum, rowIdx + 1, rowCount)
                
                processedIdNumbers.Add idNum, curridNum
            End If
        Next rowIdx
        
        Dim vKey As Variant
        For Each vKey In processedIdNumbers.Keys
        
            Dim idRange As Range
            Set idRange = processedIdNumbers(vKey)
            calc.Activate
            calc.Cells.Clear
            
            full.Activate
            idRange.Copy calc.Range("A1")
            
            Dim palRow As Long
            palRow = DetermineRowTarget()
            
            CopyToPal idRange, palRow
        Next
    End Sub

    Private Function GetAggregatedRangeForIdNumber(idNumber As Long, startRow As Long, rowCount As Long) As Range
        Dim allidNum As Range
        Dim nextRange As Range
        
        Dim rowIdx As Long
        For rowIdx = startRow To rowCount
            Set nextRange = full.Cells(rowIdx, idNumberColumn)
            If nextRange.Value = idNumber Then
                If allidNum Is Nothing Then
                    Set allidNum = nextRange
                Else
                    Set allidNum = Union(allidNum, nextRange)
                End If
            End If
        Next rowIdx
        Set GetAggregatedRangeForIdNumber = allidNum.EntireRow
    End Function
    
    'formerly OrganizeAndCopyToPal  
    'Contains some magic numbers to assign names 
    Function DetermineRowTarget() As Long
        
        calc.Activate
        
        Dim rowCount As Long
        rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row
        
        Dim palRow As Long
        '******************************* 
        '              code truncated for brevity
        '******************************* 
        
        DetermineRowTarget = palRow
        
    End Function