Выполнение кода замедляется после выполнения нескольких сотен циклов - PullRequest
Новая
       59

Выполнение кода замедляется после выполнения нескольких сотен циклов

0 голосов
/ 09 января 2020

Я создал простой макрос для копирования значений из одной таблицы книги в другую на основе ключа строка за строкой. Когда есть совпадение между исходной и целевой таблицами, мы добавляем значения в таблицу, где нет соответствия, мы добавляем их в последнюю строку +1. Значения 10 ячеек в 1 строке. Сверх того, что нужно сделать, это разделить значения на 1000, и там, где в исходных файлах нет значения, оно пустое, а не 0.

Проблема: после первых 500-1000 (это случайно ... ) петли макрос замедляется с 100 петель / сек c до 1 л oop за 2-3 секунды. Это довольно проблематично, когда нужно go дважды через ~ 70000 строк. И я понятия не имею, почему ...

Подскажите, пожалуйста, в чем может быть проблема? Код ниже. 

Sub

Dim Key As String
Dim r As Long, lr As Long, lr_ship As Long
Dim c As Long, lc As Long
Dim fc As Long, flc As Long, fsc As Long
Dim Current_Month As String, Ship_Date As String, Start_Month As String
Dim Value_Row As Long, xValue_Row
Dim Rng As Range, WorkRng As Range, xNum As Integer
Dim myRange As Range

(some preps...)

lr = 'last row in source
lr_ship = 'last row in dest
lc = 'last column 
flc = 'first col to use
xNum = 1000

(...)

For r = 55 To lr

    If Left(WB_Bex.Sheets("Monthly").Cells(r, 5).Value, 8) = "Shipment" And Left(WB_Bex.Sheets("Monthly").Cells(r, 4).Value, 3) = "His" Then

        xValue_Row = Null
        Value_Row = 0
        Key = WB_Bex.Sheets("Monthly").Cells(r, 1) & WB_Bex.Sheets("Monthly").Cells(r, 2) & WB_Bex.Sheets("Monthly").Cells(r, 5)

        Set myRange = Raw_Ship.Range("A1:A" & lr_ship)

       If Not IsError(Application.Match(Key, myRange, 0)) Then

            Value_Row = Application.Match(Key, myRange, 0)

            Raw_Ship.Range(Raw_Ship.Cells(Value_Row, fsc), Raw_Ship.Cells(Value_Row, fc)).Value2 = WB_Bex.Sheets("Monthly").Range(WB_Bex.Sheets("Monthly").Cells(r, 6), WB_Bex.Sheets("Monthly").Cells(r, c)).Value2
            Set WorkRng = Raw_Ship.Range(Raw_Ship.Cells(Value_Row, fsc), Raw_Ship.Cells(Value_Row, fc))

            For Each Rng In WorkRng
                If IsError(Rng.Value) = True Then
                    Rng.Value = 0
                Else
                    Rng.Value2 = WorksheetFunction.IfError(Rng.Value2 / xNum, 0)
                End If
            Next

        Else

            Raw_Ship.Cells(lr_ship, 2).Value2 = WB_Bex.Sheets("Monthly").Cells(r, 1).Value2
            Raw_Ship.Cells(lr_ship, 3).Value2 = WB_Bex.Sheets("Monthly").Cells(r, 2).Value2
            Raw_Ship.Cells(lr_ship, 4).Value2 = WB_Bex.Sheets("Monthly").Cells(r, 5).Value2
            Raw_Ship.Range(Raw_Ship.Cells(lr_ship, fsc), Raw_Ship.Cells(lr_ship, fc)).Value2 = WB_Bex.Sheets("Monthly").Range(WB_Bex.Sheets("Monthly").Cells(r, 6), WB_Bex.Sheets("Monthly").Cells(r, c)).Value2

            Set WorkRng = Raw_Ship.Range(Raw_Ship.Cells(lr_ship, fsc), Raw_Ship.Cells(lr_ship, fc))

            For Each Rng In WorkRng
'                If IsError(Rng.Value) = True Then
'                    Rng.Value = 0
'                Else
                    Rng.Value2 = WorksheetFunction.IfError(Rng.Value2 / xNum, 0)
'                End If
            Next

            lr_ship = lr_ship + 1

        End If

    End If

    Application.CutCopyMode = False

Next r

End Sub
...