VBA - Ускорение кода?

Question

У меня есть код, который смотрит на данные, вызывает данные, которые не каталогизированы, копирует данные на новый лист и удаляет строки с ошибками. Макрос работает EXTREMELY медленно, и мне нужно запустить его дважды, чтобы удалить строки с ошибками на новых листах. Любые предложения о том, как я могу его улучшить? Огромное спасибо!

Sub SynthData() 
Dim rCell As Range 
Dim lColor As Long 
Dim rColored As Range 
Dim c As Range 
Dim rng As Range 

Application.ScreenUpdating = False 

lColor = RGB(255, 255, 0) 

With Worksheets("Output").Columns("D") 
Lastrow = .Find("*", After:=.Cells(1), _ 
    LookIn:=xlValues, SearchDirection:=xlPrevious).Row 
End With 
'Finds last row 

For Each c In Worksheets("Output").Range("E1:E" & Lastrow) 
If c.Offset(0, 1) = "#N/A" Then 
    c.Interior.Color = lColor 
Else: c.Interior.Color = xlNone 
End If 
Next c 
'Highlights cells with adjacent errors 

Set rColored = Nothing 
For Each rCell In Worksheets("Output").Range("A1:G" & Lastrow) 
    If rCell.Interior.Color = lColor Then 
     If rColored Is Nothing Then 
      Set rColored = rCell 
     Else 
      Set rColored = Union(rColored, rCell) 
     End If 
    End If 
Next 
If rColored Is Nothing Then 

    Worksheets("Source").Range("A3:G2000").ClearContents 

With Worksheets("Output").Columns("D") 
    Lastrow = .Find("*", After:=.Cells(1), _ 
     LookIn:=xlValues, SearchDirection:=xlPrevious).Row 
End With 
    'finds last row in data 

    Worksheets("Output").Range("A1:G" & Lastrow).Copy 
Worksheets("Source").Range("A3").PasteSpecial xlPasteValues 
'copies it over 

With Worksheets("Source").Columns("F") 
    lngrow = .Find("*", After:=.Cells(1), _ 
     LookIn:=xlValues, SearchDirection:=xlPrevious).Row 
     For i = lngrow To 1 Step -1 
     If (Cells(i, "F").Value) = "NA" Then 
      Cells(i, "A").EntireRow.Delete 
      'Deletes catalogued NAs 
     End If 
    Next i 
    End With 

    Application.CutCopyMode = False 

On Error Resume Next 
     If  Worksheets("source").Range("Table4[[Company]]").SpecialCells(xlCellTypeBlanks).Count > 0 Then 
    Worksheets("source").Range("Table4[[Company]]").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
'Deletes blank cells in table 

    End If 

    Else 
    rColored.Select 
    MsgBox "Selected cells contain data that are not catalogued in the refrence table. Please catalogue them before preeceding:" & _ 
     vbCrLf & rColored.Address 
End If 

Set rCell = Nothing 
Set rColored = Nothing 
ActiveWorkbook.RefreshAll 
Application.ScreenUpdating = True 
End Sub 

Answer 1

Вы можете попробовать отключить автоматическое вычисление, как удаление строк будет вызывать все открытые рабочие книги пересчитывать ...

Dim calcMode As XlCalculation 
calcMode = Application.Calculation 
Application.Calculation = xlCalculationManual 

'do stuff... 

Application.Calculation = calcMode 

Если это не помогает, то посмотрите на вытягивать содержимое листа в переменную массива и работать над этим вместо рабочего листа, как описано here.

Answer 2

Я не вижу какой-либо конкретной оптимизации, однако вы можете добавить до исполнения:

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

А затем обратить его в конце:

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 
Application.EnableEvents = True 

Answer 3

Спасибо за советы ! Я ускорил код примерно на 50%, внес некоторые из рекомендуемых изменений. Пересмотренный код приведен ниже. Он по-прежнему занимает 30 секунд +, чтобы запустить хотя ...

Sub SynthData() 
    Dim rCell As Range 
    Dim lColor As Long 
    Dim rColored As Range 
    Dim c As Range 
    Dim rng As Range 
    Dim lngrow As Long 
    Dim LastRow As Long 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

lColor = RGB(255, 255, 0) 

With Worksheets("Output").Columns("D") 
    LastRow = .Find("*", After:=.Cells(1), _ 
     LookIn:=xlValues, SearchDirection:=xlPrevious).Row 
End With 
'Finds last row 

For Each c In Worksheets("Output").Range("E1:E" & LastRow) 
    If c.Offset(0, 1) = "#N/A" Then 
    c.Interior.Color = lColor 
    Else: c.Interior.Color = xlNone 
    End If 
Next c 
'Highlights cells with adjacent errors 

    Set rColored = Nothing 
    For Each rCell In Worksheets("Output").Range("A1:G" & LastRow) 
     If rCell.Interior.Color = lColor Then 
      If rColored Is Nothing Then 
       Set rColored = rCell 
      Else 
       Set rColored = Union(rColored, rCell) 
      End If 
     End If 
    Next 

If rColored Is Nothing Then 
    Worksheets("Source").Range("A3:G2000").ClearContents 

    lngrow = Worksheets("Output").Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 
    'finds last row in data 

     For i = lngrow To 1 Step -1 
      If Worksheets("Output").Cells(i, "F").Value = "NA" Then 
       Worksheets("Output").Cells(i, "A").EntireRow.Delete 
       'Deletes catalogued NAs 
      End If 
     Next i 

    LastRow = Worksheets("Output").Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 
    'finds last row in data 

    Worksheets("Output").Range("A1:G" & LastRow).Copy 
    Worksheets("Source").Range("A3").PasteSpecial xlPasteValues 
    'copies it over 

    On Error Resume Next 
     If Worksheets("source").Range("Table4[[Company]]").SpecialCells(xlCellTypeBlanks).Count > 0 Then 
     Worksheets("source").Range("Table4[[Company]]").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
     'Deletes blank cells in table 
     End If 

Else 
    rColored.Select 
    MsgBox "Selected cells contain data that are not catalogued in the refrence table. Please catalogue them before preeceding:" & _ 
    vbCrLf & rColored.Address 
End If 

Set rCell = Nothing 
Set rColored = Nothing 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 
Application.EnableEvents = True 
Application.CutCopyMode = False 
ActiveWorkbook.RefreshAll 
End Sub 

Answer 4

Попробуйте это:

Private Sub CommandButton1_Click() 
Dim rCell As Range 
Dim lColor As Long 
Dim c As Range 
Dim r As Integer 
Dim rRange As Range 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
lColor = RGB(255, 255, 0) 
r = 1 

'Find the last row 
With Worksheets("Output").Columns("D") 
Lastrow = .Find("*", After:=.Cells(1), _ 
    LookIn:=xlValues, SearchDirection:=xlPrevious).Row 
End With 


'Highlight cells with adjacent errors 
For Each c In Worksheets("Output").Range("E1:E" & Lastrow) 
    If Application.IsNumber(c.Offset(0, 1)) Then 
     GoTo Continue1 
    Else 
     If c.Offset(0, 1) = "#N/A" Then 
      For Each c2 In Worksheets("output").Range("A" & c.Row & ":G" & c.Row) 
      c2.Interior.Color = lColor 
      Next c2 
     Else: c.Interior.Color = xlNone 
     End If 
Continue1: 
    End If 
Next c 


' Add a sheet called OutputTemp and copy the values from the worksheet Output 
Application.Sheets.Add 
With Application.ActiveSheet 
    .Name = "OutputTemp" 
    Application.Sheets("Output").Cells.Copy 
    .Range("A1").PasteSpecial Paste:=xlPasteValues 
    '.Range("B1").Value = Me.DTPicker10.Value 
End With 

'audit the worksheet called OutputTemp and delete any lines with errors 
For r = 1 To Lastrow 
    Set rRange = Application.Worksheets("OutputTemp").Range("E" & r & ":E" & r) 
    If Application.IsNumber(rRange.Offset(0, 1)) Then 
     GoTo Continue2 
    Else 
     If rRange.Offset(0, 1) = "#N/A" Then 
      rRange.EntireRow.Delete 
      r = r - 1 
     End If 
Continue2: 
    End If 

Next r 


'Clear previous contents of the worksheet called Source and then copy the data from OutputTemp 
Worksheets("Source").Cells.Clear 
Worksheets("OutputTemp").Range("A1:G" & Lastrow).Copy 
Worksheets("Source").Range("A3").PasteSpecial xlPasteValues 

'Delete the worksheet called OutputTemp 
Worksheets("OutputTemp").Delete 
ActiveWorkbook.RefreshAll 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
End Sub