VBA: Удивительно медленный макрос для работы с несколькими листами (15 минут для строк по 7 тысяч!)

Question

У меня есть файл excel с двумя листами, а именно;Material Sheet и Resultant Sheet, где последний является пустым листом для результатов.В Material Sheet у меня есть информация о материале вместе с кодами движения.Что касается схемы:

columnA has MaterialCodes & columnG has MovementCodes

Теперь для каждого материала может быть несколько строк с различными кодами движения из набора кодов движения (101,102,201,202,241,242,261,262,561).Мне нужно проверить применение следующей логики:

скопировать все строки материала из Material Sheet и вставить в Resultant Sheet`,
if (count-of-202-for-this-материал> = количество-201-для-этого-материала) И (количество-242-для-этого-материала> = количество-241-для-этого-материала) И (количество-из-262-for-this-material> = count-of-261-for-this-material)

На данный момент у меня есть следующий код (конец сообщения).В ходе этого процесса он фильтрует действительные коды материалов и сохраняет эти коды в Результирующем листе (еще не всю строку!)

Что я хочу:

1. Мне нужно изменить его таквсе результирующие строки для каждого отфильтрованного материала должны быть скопированы в Результирующий лист.
2. Существующий код занимает слишком много (например, 15 минут) времени выполнения для ~ 7000 значений.ОЧЕНЬ МЕДЛЕННО!

FilterWRTMovement - это основная процедура драйвера.Он вызывает функцию collectUniqueMaterials для сбора уникальных материалов из columnA в массив collectionUniqueMaterials.Затем для каждого уникального материала он собирает коды движения из столбца g таблицы материалов и проверяет вышеупомянутую логику в функции FilterValues.

Sub FilterWRTMovement()
    Application.ScreenUpdating = False
    Dim collectionUniqueMaterials() As String
    Dim LRow As Long, counter1 As Long, counter2 As Long
        Dim result(10000) As String, movementOfOneMaterial() As String, current As String
    Dim has202 As Boolean, has242 As Boolean, has262 As Boolean
    Dim Destination As Worksheet

    LRow = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
    c = collectUniqueMaterials(collectionUniqueMaterials, LRow)
    counter1 = 0
    counter2 = 0
    Set Destination = Worksheets("Resultant Sheet")

    With ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & LRow)
        .EntireRow.Hidden = False
        For Each i In collectionUniqueMaterials
            i = Trim(i)
            ReDim movementOfOneMaterial(200) As String
            has202 = True
            has242 = True
            has262 = True
            counter1 = 0

            For j = 1 To .Rows.Count
                current = Trim(Cells(j, 1))
                If current = i Then
                    movementOfOneMaterial(counter1) = Cells(j, 7)
                    counter1 = counter1 + 1
                End If
            Next j

            FilterValues movementOfOneMaterial, has202, has242, has262
            If has202 = True And has242 = True And has262 = True Then
                result(counter2) = i
                counter2 = counter2 + 1
            End If
            Erase movementOfOneMaterial
        Next i
    End With
    Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result)

    'For Each tup In result
    'FindMe (tup)
    'Next tup
End Sub

Function collectUniqueMaterials(ByRef collection() As String, ByRef last As Long)
    Dim tmp As String

    myselect = ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & last)
    For Each cell In myselect
        If (cell <> "") And (InStr(tmp, cell) = 0) Then
            tmp = tmp & cell & "|"
        End If
    Next cell

    If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
    collection = Split(tmp, "|")
End Function



Function FilterValues(ByRef sarrCodes() As String, ByRef has202 As Boolean, ByRef has242 As Boolean, ByRef has262 As Boolean)
    Dim a As Long
    Dim vKey As Variant
    Dim objDic As Object


    Set objDic = CreateObject("Scripting.Dictionary")

    For a = LBound(sarrCodes) To UBound(sarrCodes)
        If objDic.Exists(sarrCodes(a)) Then
            objDic.Item(sarrCodes(a)) = objDic.Item(sarrCodes(a)) + 1
        Else
            objDic.Add sarrCodes(a), 1
        End If
    Next a

    If objDic.Exists("201") And objDic.Item("201") <> "" Then
        has202 = False
        If objDic.Exists("202") And objDic.Item("202") <> "" And objDic.Item("202") >= objDic.Item("201") Then
            has202 = True
        End If
    ElseIf objDic.Exists("241") And objDic.Item("241") <> "" Then
        has242 = False
        If objDic.Exists("242") And objDic.Item("242") <> "" And objDic.Item("242") >= objDic.Item("241") Then
            has242 = True
        End If
    ElseIf objDic.Exists("261") And objDic.Item("261") <> "" Then
        has262 = False
        If objDic.Exists("262") And objDic.Item("262") <> "" And objDic.Item("262") >= objDic.Item("261") Then
            has262 = True
        End If
    End If
End Function

Ваша помощь будет принята с благодарностью.

РЕДАКТИРОВАТЬ

После включения предложений от iDevelp, Issun & Nick Hebb, следующий код, который занимает 30 секунд, чтобы выполнить

Sub FilterWRTMovement()
    Application.ScreenUpdating = False
    Dim collectionUniqueMaterials() As String, result(10000) As String, movementOfOneMaterial() As String, current As String
    Dim LRow As Long, counter1 As Long, counter2 As Long
    Dim has202 As Boolean, has242 As Boolean, has262 As Boolean
    Dim Destination As Worksheet
    Dim materialArray As Variant, movementArray As Variant

    LRow = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
    c = collectUniqueMaterials(collectionUniqueMaterials, LRow)
    counter1 = 0
    counter2 = 0
    Set Destination = Worksheets("Resultant Sheet")


    materialArray = Worksheets("Material Sheet").Range("A2:A" & LRow)
    movementArray = Worksheets("Material Sheet").Range("G2:G" & LRow)

    For Each i In collectionUniqueMaterials
        i = Trim(i)
        ReDim movementOfOneMaterial(200) As String
        has202 = True
        has242 = True
        has262 = True
        counter1 = 0

        For j = 1 To LRow - 1
            current = materialArray(j, 1)
            If current = i Then
                movementOfOneMaterial(counter1) = movementArray(j, 1)
                counter1 = counter1 + 1
            End If
        Next j

        FilterValues movementOfOneMaterial, has202, has242, has262
        If has202 = True And has242 = True And has262 = True Then
            result(counter2) = i
            counter2 = counter2 + 1
        End If
        Erase movementOfOneMaterial
    Next i
    Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result)

    'For Each tup In result
    'FindMe (tup)
    'Next tup
End Sub

Теперь вместо сохраненияуникальные коды материалов в Resultant Sheet (Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result)), что было бы оптимальным способом скопировать все строки из «Sheet Sheet» для каждого значения массива result (учитывая: для каждого значения элемента результата есть несколько строкв листе материалов. Я хочу, чтобы все они получили отфильтрованные данные)

ОБНОВЛЕНИЕ С небольшим изменением в посте Тима я могу достичь желаемого результата за секунду.Ниже приведен сценарий VBA:

Sub FilterMaterialWRTMovement()

    Const SourceSheet As String = "Material Sheet"
    Const DestinationSheet As String = "Resultant Sheet"

    Const COL_ID As Integer = 1
    Const COL_MOVE As Integer = 7

    Dim dict As Object
    Dim data As Variant, data2(), numRows As Long, numCols As Long
    Dim r As Long, c As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim id, mv, arrMv, pos, tmp
    Dim data2Row As Long
    Dim firstPass As Boolean

     Set dict = CreateObject("Scripting.Dictionary")
        'movement codes to count
        arrMv = Array(201, 202, 241, 242, 261, 262)

        Set shtSrc = ActiveWorkbook.Sheets(SourceSheet)
        Set shtDest = ActiveWorkbook.Sheets(DestinationSheet)

        shtDest.Cells.Clear

        data = shtSrc.Range(shtSrc.Range("A2"), _
               shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 10)).Value

        numRows = UBound(data, 1)
        numCols = UBound(data, 2)

        ReDim data2(1 To numRows, 1 To numCols)

        data2Row = 1
        firstPass = True

runAgain:
        For r = 1 To numRows
            id = data(r, COL_ID)

            If firstPass Then
                'collecting counts...
                mv = data(r, COL_MOVE)
                If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0)
                pos = Application.Match(mv, arrMv, 0)
                If Not IsError(pos) Then
                    tmp = dict(id)
                    If id = 7024113 Then
                    cwe = 1
                    End If
                    tmp(pos - 1) = tmp(pos - 1) + 1
                    dict(id) = tmp
                End If
                'firstPass = False
            Else
                'copying rows
                tmp = dict(id)
                If (tmp(0) <> 0) Or (tmp(2) <> 0) Or (tmp(4) <> 0) Then
                    If Not ((tmp(0) <> 0 And tmp(1) < tmp(0)) Or (tmp(2) <> 0 And tmp(3) < tmp(2)) Or (tmp(4) <> 0 And tmp(5) < tmp(4))) Then
                        For c = 1 To numCols
                            data2(data2Row, c) = data(r, c)
                        Next c
                        data2Row = data2Row + 1
                    End If
                End If
            End If
        Next r

        If firstPass Then
            Beep
            firstPass = False
            GoTo runAgain
        Else
            shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2
        End If

End Sub

Большое спасибо, ребята!

Answer 1

Уже хорошо решено, но вот другой подход.Мне было бы интересно попробовать реальные данные, если бы вы могли сделать их доступными ... В моем тестировании: 85 тыс. Строк было примерно 3-4 секунды

Sub FilterAndCopyRows()

Const COL_ID As Integer = 1
Const COL_MOVE As Integer = 7

Dim dict As New Scripting.dictionary
Dim data As Variant, data2(), numRows As Long, numCols As Long
Dim r As Long, c As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim id, mv, arrMv, pos, tmp
Dim data2Row As Long
Dim firstPass As Boolean

    'movement codes to count
    arrMv = Array(201, 202, 241, 242, 261, 262)

    Set shtSrc = ActiveWorkbook.Sheets("Material Sheet")
    Set shtDest = ActiveWorkbook.Sheets("Resultant Sheet")

    data = shtSrc.Range(shtSrc.Range("A2"), _
           shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 6)).Value

    numRows = UBound(data, 1)
    numCols = UBound(data, 2)

    ReDim data2(1 To numRows, 1 To 7)

    data2Row = 1
    firstPass = True

runAgain:
    For r = 1 To numRows
        id = data(r, COL_ID)

        If firstPass Then
            'collecting counts...
            mv = data(r, COL_MOVE)
            If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0)
            pos = Application.Match(mv, arrMv)
            If Not IsError(pos) Then
                tmp = dict(id)
                tmp(pos - 1) = tmp(pos - 1) + 1
                dict(id) = tmp
            End If
        Else
            'copying rows
            tmp = dict(id)
            If (tmp(1) > tmp(0)) And (tmp(3) > tmp(2)) And (tmp(5) > tmp(4)) Then
                For c = 1 To numCols
                    data2(data2Row, c) = data(r, c)
                Next c
                data2Row = data2Row + 1
            End If
        End If
    Next r

    If firstPass Then
        Beep
        firstPass = False
        GoTo runAgain
    Else
        shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2
    End If

End Sub

Answer 2

Два наблюдения:

(как уже упоминалось в iDevelop) .Rows.Count добавит много ненужных накладных расходов. Кроме того, LRow уже не настроен на номер последней строки?

Кроме того, если я правильно читаю код, вы добавляете значения в массив, а затем подсчитываете их в подпрограмме FilterValues. Разве нельзя было бы добавить их в словарь и увеличивать их за один проход вместо того, чтобы иметь вложенные циклы и делать вызов FilterValues?

Answer 3

Какая версия Excel это? Если 2007 или 2010, виновником может быть For j = 1 To .Rows.Count, работающий с большим количеством ненужных ячеек. Вы можете попробовать использовать
For Each c In Range("a:a").SpecialCells(xlCellTypeConstants) вместо этого.

Answer 4

Увидев комментарий вулканского ворона, я отправляю ответ

Таким образом, всякий раз, когда изменяется содержание (я) ячейки или диапазона ячеек, зависимые от них формулы и изменчивые функции пересчитываются. Вы можете отключить автоматический расчет, используя

Application.Calculation = xlCalculationManual 'turn off the automatic calc
  'your code goes here
Application.Calculation = xlCalculationAutomatic 'turn On the automatic calc

проверить эти ссылки для оптимизации в VBA

http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm

http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html

http://www.cpearson.com/excel/optimize.htm

а также не использовать

if a = "" or a = "" 'thats not good way to do 

попробуйте использовать встроенные ключевые слова vbnullstring, а также проверьте эти ссылки для оптимизации строки

http://www.aivosto.com/vbtips/stringopt.html (предложено brettdj).

Это даст вам много знаний по оптимизации строк.

Надеюсь, вы узнали что-то новое сегодня :). Спасибо