遅い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