Question

我有一些代码可以查看数据，调出未编目的数据，将数据复制到新工作表，并删除有错误的行。宏运行速度非常慢，我需要运行两次才能删除新工作表上有错误的行。有关如何改进它的任何建议？非常感谢！

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

Try this out:

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

VBA - 加速代码？

4 个答案: