優化緩慢的VBA代碼

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