Question

我有以下代码 - 其中大部分是用宏录制器录制的。它很慢，似乎有点不可靠（有时需要大约1分钟，有时需要更长时间）。

我想知道这里是否有人可以帮助我清理它并让它更有效地运行。

谢谢！

Sub RemainingMIUL()

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

    Sheets("Sheet2").Select

    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Sheets("Sheet1").Select

    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("L1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("L:L").Select
    Selection.Copy

    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste

    Sheets("Sheet1").Select

    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Sheets("Sheet2").Select
    Range("B2").Select

    Dim cell As Range

    For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp))
      If Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then cell.Interior.Color = vbYellow
    Next cell

    With Sheets("Sheet2")
        For Each cell In .Range("B2", Cells(Rows.Count, "B").End(xlUp))
            If .Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then _
            Intersect(.UsedRange, cell.EntireRow).Offset(, 1).Copy _
            Sheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Offset(1)
        Next cell
    End With


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

End Sub

Answer 1

尝试组合代码底部的2 for循环。它们都循环遍历B列并在满足相同条件时运行代码。

With Sheets("Sheet2")
    For Each cell In .Range("B2", Cells(Rows.Count, "B").End(xlUp))
        If .Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then
           Intersect(.UsedRange, cell.EntireRow).Offset(, 1).Copy    Sheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Offset(1)
           cell.Interior.Color = vbYellow
       End if
    Next cell
End With

然后您可以删除第一个循环

For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp))
  If Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then cell.Interior.Color = vbYellow
Next cell

优化慢速VBA代码

1 个答案: