Help speeding up VBA Script

[rholdren]

Good morning,

I have Office 365 Excel and seem to be having a little issue with the scrip below. It runs extremely slow and it is only pulling the first record over and stopping. The script should be reading down column AX and and wherever it finds 3% should copy the entire row and move it to another worksheet.

Any help on this would be greatly appreciated.

Thanks

Sub Create_List()

Application.ScreenUpdating = False

Sheets("OptumRxExport").Select


Last = Cells(Rows.Count, "AX").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "AX").Value) = "3%" Then

Cells(i, "AX").Select


Cells(i, "AX").EntireRow.Copy


Sheets("Discounted_List").Select
Range("a2:I50000").Select


Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveCell.PasteSpecial Paste:=xlPasteFormats



End If

Sheets("OptumRxExport").Select


Next i

End Sub

 

[Georgiboy]

If you still want to loop backwards then maybe:

Sub Create_List()
    Dim wsORxEx As Worksheet, wsDL As Worksheet, Last As Long
   
    Set wsORxEx = Sheets("OptumRxExport")
    Set wsDL = Sheets("Discounted_List")
    Last = wsORxEx.Cells(Rows.Count, "AX").End(xlUp).Row
   
    For i = Last To 1 Step -1
        If wsORxEx.Cells(i, "AX").Value = "3%" Then
        wsORxEx.Rows(i).Copy
        wsDL.Range("A" & wsDL.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
    Next i
End Sub

Else you could loop forwards with a range loop:

Sub Create_List2()
    Dim wsORxEx As Worksheet, wsDL As Worksheet, rCell As Range
  
    Set wsORxEx = Sheets("OptumRxExport")
    Set wsDL = Sheets("Discounted_List")
  
    For Each rCell In wsORxEx.Range("AX1:AX" & wsORxEx.Cells(Rows.Count, "AX").End(xlUp).Row)
        If rCell = "3%" Then
        rCell.EntireRow.Copy
        wsDL.Range("A" & wsDL.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
    Next i
End Sub

 

[Georgiboy]

Another option that may be faster is to use autofilter and then copy the visible cells and paste them elsewhere.

 

[Joe4]

I think perhaps a filter solution would be much more efficient (filter all the rows where the value in that cell = 3%).
Advanced filters let you copy to a different location.

 

[Georgiboy]

Here is an autofilter version:

Sub Create_List3()
    Dim wsORxEx As Worksheet, wsDL As Worksheet, rng As Range, rng2 As Range
    
    Set wsORxEx = Sheets("OptumRxExport")
    Set wsDL = Sheets("Discounted_List")
    Set rng = wsORxEx.UsedRange
    Set rng2 = rng.Offset(1).Resize(rng.Rows.Count - 1, rng.Columns.Count)
    
    If Not ActiveSheet.AutoFilterMode Then
        wsORxEx.Range("A1").AutoFilter
    End If
    rng.AutoFilter 50, "3%"
    rng2.SpecialCells(xlCellTypeVisible).Copy
    wsDL.Range("A" & wsDL.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
End Sub

 

[rholdren]

In the first 2 I am getting Next without For error and in the third one I'm getting a AutoFilter method of Range Class Failed error

 

[Georgiboy]

My error there on the first two, an issue with writing untested code - i missed an end if:

Sub Create_List()
    Dim wsORxEx As Worksheet, wsDL As Worksheet, Last As Long
   
    Set wsORxEx = Sheets("OptumRxExport")
    Set wsDL = Sheets("Discounted_List")
    Last = wsORxEx.Cells(Rows.Count, "AX").End(xlUp).Row
   
    For i = Last To 1 Step -1
        If wsORxEx.Cells(i, "AX").Value = "3%" Then
            wsORxEx.Rows(i).Copy
            wsDL.Range("A" & wsDL.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next i
End Sub

Sub Create_List2()
    Dim wsORxEx As Worksheet, wsDL As Worksheet, rCell As Range
  
    Set wsORxEx = Sheets("OptumRxExport")
    Set wsDL = Sheets("Discounted_List")
  
    For Each rCell In wsORxEx.Range("AX1:AX" & wsORxEx.Cells(Rows.Count, "AX").End(xlUp).Row)
        If rCell = "3%" Then
            rCell.EntireRow.Copy
            wsDL.Range("A" & wsDL.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next i
End Sub

 

[Georgiboy]

For the filter version change the below:

rng.AutoFilter 50, "3%"

To

rng.AutoFilter 37, "3%"

Not sure why but i thought column AK was 50...

 

[rholdren]

Georgiboy,​

Thank you so much. It is greatly appreciated.