Лучший способ скопировать данные на новый лист и реорганизовать его (VBA)

Я пишу программу VBA, которая копирует и организует данные с одного мастер-листа на множество других листов. Один из листов-получателей объединяет все данные из мастер-листа, который содержит тот же идентификационный номер, в одну строку. Для этой операции я просматриваю основной лист для каждого номера идентификатора, копирую каждую строку, которая содержит текущий номер идентификатора, на новый лист, используемый исключительно для вычислений и организации, и переставляю данные на этом листе в новую строку. Результирующая строка копируется в лист получателя. Этот процесс организации данных для каждого идентификационного номера занимает много времени, особенно с учетом очень большого размера этого листа и времени обработки других листов-получателей. Мне интересно, есть ли лучший способ организовать и скопировать данные без использования промежуточного листа расчетов.

Приведенный ниже код — это основная подпрограмма, которая вызывает другую подпрограмму OrganizeAndCopyToPal, которая организует данные в листе расчета и копирует результат в лист получателя.

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

Приведенная ниже подгруппа упорядочивает и копирует данные для каждого идентификационного номера. Последняя подпрограмма для копирования данных не связана с упрощением этой задачи, поэтому я ее не включаю.

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

Спасибо за любые советы или помощь, которые вы можете предложить.

Некоторые комментарии, которые вы, надеюсь, найдете полезными:

1. (Лучшая практика) Объявите «Option Explicit» в верхней части каждого модуля. Эта опция требует, чтобы каждая переменная, используемая в модуле, была явно объявлена. Это позволяет избежать множества ошибок, не последнюю из которых новые переменные, объявленные опечаткой что может быть трудно обнаружить. Объявление его в верхней части предоставленного кода привело к необходимости добавить 9 объявлений.
2. (Лучшая практика) Явно объявляйте типы для ваших переменных и параметров. Dim idNum неявно заявляет idNum есть Variant. Вероятно, это Long — но теперь читателю нужно просмотреть код, чтобы узнать, Конечно. Sub OrganizeAndCopyToPal(curridNum) => параметр curridNum по умолчанию объявлен как вариант, но это Range. Sub OrganizeAndCopyToPal(curridNum As Range) устраняет всю двусмысленность.

Именование вещей.

1. Вы можете изменить кодовое имя рабочих листов (например, Sheet3). Так что нет необходимости Dim calc As Worksheet, Set cal = Sheet3. Просто переименовать Sheet3 к calc в окне свойств. Теперь не нужно объявлять и присваивать calc в вашем коде — вы можете просто использовать его напрямую как объект Worksheet. Тот же комментарий для full а также pal.
2. Используйте значащие имена. Односимвольные имена не описательны и (IMO) затрудняют чтение кода. Даже переменные индекса цикла и массива легче интерпретировать, если им даны имена, такие как ‘idxRow’, ‘rowNum’ и т. Д. Описательные имена не замедлят ваш код и не займут слишком много памяти. Какое описательное имя будут do позволяет избежать много времени на повторную интерпретацию, когда вы хотите обновить этот код после долгого отсутствия.

Не повторяйся (СУХОЙ) и магические числа:

1. В качестве примера, PalletAssemblyLog повторяет выражение full.Cells(j, 17) 3 раза по 5 строк. Это выражение повторяется и содержит «магическое число» — 17. 17 должно быть важным столбцом в таблице. full рабочий лист … дайте ему имя! (full также можно использовать более информативное имя). Private Const idNumberColumn As Long = 17 не замедлит код, но он намного более читабелен … и, что наиболее важно, как только вам нужно вставить новый столбец перед столбцом 17, вам нужно будет изменить номер столбца только в одном месте.
2. Sub OrganizeAndCopyToPal(curridNum) использует множество магических чисел, которым нужно имя: 2,5,4,8,10,16. Дайте им все имена и присвойте им постоянные значения в одном месте. Вы будете благодарить себя в будущем, когда calc рабочий лист в конечном итоге реорганизуется.

Принцип единой ответственности (SRP): каждая процедура должна иметь единственную цель (или иметь единственную причину для изменения)

1. В OrganizeAndCopyToPal Процедура по своему названию показывает, что она выполняет две функции: организует и копирует. Фактически, переданный аргумент curridNum не используется до конца OrganizeAndCopyToPal когда это параметр в выражении CopyToPal curridNum, palRow. Нет необходимости проходить curridNum в качестве параметра, потому что подпрограмме не нужно знать curridNum чтобы определить palRow. Расчет palRow это единственная ответственность — подумайте о том, чтобы сделать OrganizeAndCopyToPal такую ​​функцию, как ‘Function DetermineRowTarget () As Long’.
2. Не стесняйтесь выделять блоки кода из процедур, которые можно объяснить / задокументировать с помощью имени функции. В PalletAssemblyLog, существует вложенный цикл, который собирает все диапазоны, относящиеся к одному и тому же номеру идентификатора. Вместо того, чтобы просеивать логику цикла, чтобы выяснить, что именно делает, можно было бы лучше самодокументировать, превратив ее в функцию, которая возвращает palRow. В этом случае он получает бонусные баллы за сокращение вложенности петель.

Скорость

1. В основном цикле вы активируете рабочие листы несколько раз. Мне непонятно, нужно ли вам сделать различные листы «Активными» для имеющегося у вас кода модификации. Простое уменьшение / удаление всего, что вызывает перерисовку внутри цикла, ускорит процесс.
2. Похоже, вы обрабатываете полный набор idNum строк каждый раз, когда вы увеличиваете idNum. Если это правда, это означает, что вы повторяете операции много-много раз, чем необходимо. Измените логику, чтобы обрабатывать только каждый idNum однажды. Это должно значительно ускорить ваш процесс. Один из способов сделать это — кэшировать Range результат для каждого idNum. Итак, в следующий раз, когда вы столкнетесь с idNum, вы можете пропустить это. Кроме того, внутренний цикл должен начинаться со строки + 1 нового idNum. Это позволяет избежать повторения ранее оцененных строк. В приведенном ниже примере используется Dictionary кэшировать Range полученные результаты. Когда-то все Ranges для каждого idNum определены, он выполняется, хотя каждый idNum Организовать как раньше.
3. Во время операций временно отключить обновление экрана и вычисления (если операция не зависит от вычислений)

Ниже приведен код с некоторыми изменениями, описанными выше.

    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