VBA to copy based on specific criteria

[rudolphc83]

Hi Guys

I'm new here and I have been searching for hours, so please forgive me if there is a thread for this already.

I have a data file, approx 20k line items that I need to report on. From this data certain line items needs to be copied to other worksheets in the same workbook based on certain criteria. The code I am currently using works fine but it's crazy slow due to it being a loop based macro. What I need to do is get the same result but with something a little more lightweight. Could you please help?

Here is the code I currently use, it is only a part of the entire code, but the idea is still there:

---

Sub SplitData()


Worksheets("Open OBD").Activate


Dim lr As Long, lr2 As Long, lr3 As Long, Lr4 As Long, lr5 As Long, r As Long
lr = Sheets("Open OBD").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("PAN003 NON-ECC").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("PAN003 INT").Cells(Rows.Count, "A").End(xlUp).Row
Lr4 = Sheets("Not in PP").Cells(Rows.Count, "A").End(xlUp).Row
lr5 = Sheets("PANBCT DOM").Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 2 Step -1
    
        Select Case Range("N" & r).Value
            Case Is = "Not Processed"
                Rows(r).Copy
                With Sheets("Not in PP").Range("A" & Lr4 + 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Lr4 = Sheets("Not in PP").Cells(Rows.Count, "A").End(xlUp).Row
                End With
        End Select
        
        Select Case Range("W" & r).Value
            Case Is = "NO"
                Rows(r).Copy
                With Sheets("PAN003 NON-ECC").Range("A" & lr2 + 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    lr2 = Sheets("PAN003 NON-ECC").Cells(Rows.Count, "A").End(xlUp).Row
                End With
        End Select
    
    Next r
End Sub

---

Thanks for the help guys

 

[Fluff]

How about

Sub SplitData()
   Dim Ws As Worksheet
   Dim i As Long
   Dim Ary As Variant
   
   Set Ws = Sheets("pcode")
   Ary = Array([COLOR=#ff0000]"Not Processed[/COLOR]", [COLOR=#0000ff]14[/COLOR], "Not in PP", "[COLOR=#ff0000]NO[/COLOR]", [COLOR=#0000ff]23[/COLOR], "PAN003 NON-ECC")
   
   For i = 0 To UBound(Ary) Step 3
      If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
      Ws.Range("A1:Z1").AutoFilter Ary(i + 1), Ary(i)
      On Error Resume Next
      Ws.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy
      With Sheets(Ary(i + 2)).Range("A" & Rows.Count).End(xlUp).Offset(1)
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteFormats
      End With
            On Error GoTo 0

   Next i
   Ws.AutoFilterMode = False
End Sub

Simply expand the Ary, wher the values in red are your filter criteria, the values in blue are the column numbers & the values in black are your sheet names.

 

[Fluff]

Cross posted https://www.ozgrid.com/forum/forum/...os/1203330-vba-to-copy-rows-based-on-criteria

Cross-Posting
While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[rudolphc83]

Hi

Thanks< i'll give this a try, I like the idea of using less code to do the same.

 

[rudolphc83]

Apologies, I'll remember in Future to reference a cross post.

I did get some interesting info from the cross post though that I would like to share here:

As suggested by Alan at Ozgrid I added the following to my original code:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'At beginning of code

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

This made a massive difference in the time the macro took to run, instead of minutes it ran in mere seconds.