SOLVED

VBA copy specific criteria

Copper Contributor

I have a workbook with 4 sheets: first one is the raw data sheet, then 3 target sheets.

I would need a macro that would look at cell C in raw data sheet and based on the criteria values between 1 and 30 days), will copy and paste the range A:Y in "1 to 30 Days Sheet". Example: if on  Column No of Days  in raw data sheet  have  between 31 and 60 days , copy A2:Y2 and paste into "30 Days Sheet", same range A2:Y2. If instead i have the value between "31 and 60" copy A2:Y2 and paste into "31 to 60 days sheet ". Then go to next row and copy-paste A3:Y3 to sheet 61 to 90 days.
  

 Pasting my poor code below:

Sheets("Master Report").Select
Range("A2").Select
ActiveSheet.Range("$A$1:$H$627").AutoFilter Field:=6, Criteria1:=">=1", _
Operator:=xlAnd, Criteria2:="<=30"
ActiveWindow.SmallScroll Down:=-3
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A627:H627").Select
Range(Selection, Selection.End(xlUp)).Select
Range("A13:H627").Select
Range("A627").Activate
Selection.Copy
Sheets("0-30 Days

").Select
Range("B8").Select
ActiveWindow.SmallScroll Down:=-9
ActiveSheet.Paste


Sheets("Master  Report").Select
Range("A2").Select
ActiveSheet.Range("$A$1:$H$627").AutoFilter Field:=6, Criteria1:=">=31", _
Operator:=xlAnd, Criteria2:="<=60"
ActiveWindow.SmallScroll Down:=-12
Range("A8").Select
Selection.End(xlUp).Select
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A600").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
Range("A5:H619").Select
Range("A619").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("31-60 Days ").Select
Range("B8").Select
ActiveWindow.SmallScroll Down:=-9
ActiveSheet.Paste

Sheets(" Master Report").Select
ActiveSheet.Range("$A$1:$H$627").AutoFilter Field:=6, Criteria1:=">=61", _
Operator:=xlAnd, Criteria2:="<=90"
Range("A4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
Range("A2:H626").Select
Range("A626").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("61-90 Days ").Select
Range("B8").Select
Selection.End(xlUp).Select
Range("B8").Select
ActiveSheet.Paste


Sheets(" Master Report").Select
ActiveSheet.Range("$A$1:$H$1264").AutoFilter Field:=6, Criteria1:=">=91", _
Operator:=xlAnd
ActiveWindow.SmallScroll Down:=-6
Range("A795").Select
Selection.End(xlUp).Select
Range("A794").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("91+ ").Select
Range("B8").Select
Selection.End(xlUp).Select
Range("B8").Select
ActiveSheet.Paste
Sheets("Main Menu").Select

End Sub

3 Replies
best response confirmed by dhan09 (Copper Contributor)
Solution

@dhan09 

Try this as starting point. You may have to change it since your macro and description don't match.

Sub SplitData()
    Dim wshS As Worksheet
    Dim strCol As String
    Dim rng As Range
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Main Menu")
    strCol = "C"
    Set rng = wshS.Range("A1").CurrentRegion
    rng.AutoFilter Field:=3, Criteria1:=">=1", _
        Operator:=xlAnd, Criteria2:="<=30"
    rng.Copy Destination:=Worksheets("0-30 Days").Range("A1")
     rng.AutoFilter Field:=3, Criteria1:=">=31", _
        Operator:=xlAnd, Criteria2:="<=60"
    rng.Copy Destination:=Worksheets("31-60 Days").Range("A1")
    rng.AutoFilter Field:=3, Criteria1:=">=61", _
        Operator:=xlAnd, Criteria2:="<=90"
    rng.Copy Destination:=Worksheets("61-90 Days").Range("A1")
    rng.AutoFilter
   Application.ScreenUpdating = True
End Sub

@Hans VogelaarThanks for valuable input,  I'm trying add  below code for more than 91 days and I'm getting error 'Run time Error 9 : Subscript out of range"
 rng.AutoFilter Field:=3, Criteria1:=">=91", _
rng.Copy Destination:=Worksheets("91+ Days").Range("B7")
rng.AutoFilter

 

 

 

 

 

Sub SplitData()
    Dim wshS As Worksheet
    Dim strCol As String
    Dim rng As Range
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Main Menu")
    strCol = "C"
    Set rng = wshS.Range("A1").CurrentRegion
    rng.AutoFilter Field:=3, Criteria1:=">=1", _
        Operator:=xlAnd, Criteria2:="<=30"
    rng.Copy Destination:=Worksheets("0-30 Days").Range("A1")
     rng.AutoFilter Field:=3, Criteria1:=">=31", _
        Operator:=xlAnd, Criteria2:="<=60"
    rng.Copy Destination:=Worksheets("31-60 Days").Range("A1")
    rng.AutoFilter Field:=3, Criteria1:=">=61", _
        Operator:=xlAnd, Criteria2:="<=90"
    rng.Copy Destination:=Worksheets("61-90 Days").Range("A1")
     
    rng.AutoFilter Field:=3, Criteria1:=">=91", _
      rng.Copy Destination:=Worksheets("91+ Days").Range("B7")
rng.AutoFilter
   Application.ScreenUpdating = True
End Sub

 

 

 

 

  

@dhan09 

You forgot to copy a line:

Sub SplitData()
    Dim wshS As Worksheet
    Dim strCol As String
    Dim rng As Range
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Main Menu")
    strCol = "C"
    Set rng = wshS.Range("A1").CurrentRegion
    rng.AutoFilter Field:=3, Criteria1:=">=1", _
        Operator:=xlAnd, Criteria2:="<=30"
    rng.Copy Destination:=Worksheets("0-30 Days").Range("B7")
    rng.AutoFilter Field:=3, Criteria1:=">=31", _
        Operator:=xlAnd, Criteria2:="<=60"
    rng.Copy Destination:=Worksheets("31-60 Days").Range("B7")
    rng.AutoFilter Field:=3, Criteria1:=">=61", _
        Operator:=xlAnd, Criteria2:="<=90"
    rng.Copy Destination:=Worksheets("61-90 Days").Range("B7")
    rng.AutoFilter Field:=3, Criteria1:=">=91", _
        Operator:=xlAnd, Criteria2:="<=90"
    rng.Copy Destination:=Worksheets("91+ Days").Range("B7")
    rng.AutoFilter
    Application.ScreenUpdating = True
End Sub
1 best response

Accepted Solutions
best response confirmed by dhan09 (Copper Contributor)
Solution

@dhan09 

Try this as starting point. You may have to change it since your macro and description don't match.

Sub SplitData()
    Dim wshS As Worksheet
    Dim strCol As String
    Dim rng As Range
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Main Menu")
    strCol = "C"
    Set rng = wshS.Range("A1").CurrentRegion
    rng.AutoFilter Field:=3, Criteria1:=">=1", _
        Operator:=xlAnd, Criteria2:="<=30"
    rng.Copy Destination:=Worksheets("0-30 Days").Range("A1")
     rng.AutoFilter Field:=3, Criteria1:=">=31", _
        Operator:=xlAnd, Criteria2:="<=60"
    rng.Copy Destination:=Worksheets("31-60 Days").Range("A1")
    rng.AutoFilter Field:=3, Criteria1:=">=61", _
        Operator:=xlAnd, Criteria2:="<=90"
    rng.Copy Destination:=Worksheets("61-90 Days").Range("A1")
    rng.AutoFilter
   Application.ScreenUpdating = True
End Sub

View solution in original post