Optimize slow VBA code

Question

I have the following code - most of which was recorded with the macro recorder. It is slow and seems to be kind of unreliable (sometimes it takes about 1 minute and other times it takes much longer).

I am wondering if anyone here can help me clean this up and get it to run more efficiently.

Thanks!

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

Not had time to look at this properly but you appear to be looping through the cells in column B twice so you could maybe do the code to change the colour and code to copy within the same loop. Put the cell.Interior.Color = vbYellow under the copy code and add an End If below. Then delete the first For Each ... Next Cell code. Try that in the meantime. I'm sure there will be someone giving your code the full treatment. — Gordon
– Gordon, Commented Jan 31, 2017 at 23:43
if it's a working code and you only need to optimize it then post it to Code Review — user3598756
– user3598756, Commented Feb 1, 2017 at 7:55

Gordon · Accepted Answer · 2017-01-31 23:51:22Z

1

Try combining the 2 for loops that you have at the bottom of the code. They both loop through the column B and run code when the same criteria is met.

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

You can then delete the first loop

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

answered Jan 31, 2017 at 23:51

Gordon

1,1751 gold badge7 silver badges12 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

CC268 Over a year ago

Thanks that does help - is there a way to clean up my code above that? I use .Select a lot because of the macro recorder and I know that isn't best practice. @Gordon

Gordon Over a year ago

The macro recorder is a great way to find out what code you need to use. You can tidy up the sometimes redundant select code by merging the 2 lines e.g. Columns("L:L").Select Selection.Copy to Columns("L:L").Copy so you replace "Selection" with the range you've just selected. BEWARE the sections where the select is selecting a sheet. I don't think you will see too much improvement in speed but it will be tidy things up.

Collectives™ on Stack Overflow

Optimize slow VBA code

1 Answer 1

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related