优化慢VBA代码

我有下面的代码 – 其中大部分是用macroslogging器logging的。 它很慢，似乎是不可靠的（有时需要大约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个循环。 当满足相同的条件时，它们都循环遍历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