Set criteria to flexible range

[db2020]

Hi all,

In the code below I want to adjust the "criteria" line in such a way that it not refers to an array, but that it refers to a range in column A that is changing in size (sometimes it has more, sometimes it less lines) on a separate sheet (Sheet3)

How do I make this adjustment? I know that criteria should be set as range instead of variant and tried a few other things but I'm a bit stuck

Sub Seperate_Sheets()
  Dim sheetsToFsilter As Variant, sheetsColumnToFilterOn As Variant
  Dim criteria As Variant, criterium As Variant
  Dim iSht As Long
  Dim pre As String
  Dim wb1 As Workbook, wb2 As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set wb1 = ThisWorkbook
  sheetsToFilter = Array("Sheet1", "Sheet2")
  sheetsColumnToFilterOn = Array(20, 24)
  criteria = Array("Name1", "Name2")
  pre = Format(DateAdd("M", -1, Now), "mmmm")

Thanks in advance.

 

[db2020]

Anyone?

 

[Alex Blakenburg]

You are not showing the rest of your code to show us how you are using it.
See if the code below tells you what you need to know.
My arrCriteria is your "criteria"

Assumes that:
• You are using it in a filter
• That your data on sheet3 has a heading so that the actual data starts at A2
• That your filter data is Text (if not we will need to add an additional conversion to text function)

Sub FilterUsingRange()

    Dim shtCriteria As Worksheet
    Dim rngCriteria As Range
    Dim arrCriteria As Variant
    
    Set shtCriteria = Worksheets("Sheet3")
    With shtCriteria
        Set rngCriteria = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        arrCriteria = Application.Transpose(rngCriteria)
    End With
    

End Sub

 

[db2020]

Thanks Alex, I will have a look. Down below is the full code:

Sub Seperate_Sheets()
  Dim sheetsToFsilter As Variant, sheetsColumnToFilterOn As Variant
  Dim criteria As Variant, criterium As Variant
  Dim iSht As Long
  Dim pre As String
  Dim wb1 As Workbook, wb2 As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set wb1 = ThisWorkbook
  sheetsToFilter = Array("Sheet1", "Sheet2")
  sheetsColumnToFilterOn = Array(20, 24)
  criteria = Array("Name1", "Name2")
  pre = Format(DateAdd("M", -1, Now), "mmmm")

For Each criterium In criteria
    wb1.Sheets("Mapping").Copy
  Set wb2 = ActiveWorkbook
    
  For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
   With wb1.Sheets(sheetsToFilter(iSht))
        .Range("A1").AutoFilter field:=CLng(sheetsColumnToFilterOn(iSht)), Criteria1:=CStr(criterium) & "*"
        wb2.Sheets.Add After:=wb2.Sheets(wb2.Sheets.Count)
        wb2.Sheets(wb2.Sheets.Count).Name = sheetsToFilter(iSht)
        .AutoFilter.Range.EntireRow.Copy
        wb2.Sheets(sheetsToFilter(iSht)).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        .ShowAllData
        Range("A1", Cells(1, Columns.Count).End(xlToRight)).SpecialCells(xlCellTypeConstants).Interior.Color = RGB(240, 240, 240)
        Range("D1").Interior.Color = RGB(255, 255, 0)
        ActiveSheet.Range("A1").AutoFilter
        Columns("A:AE").EntireColumn.AutoFit
   End With
   With Range("A2:A" & Rows.Count).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:="=Remark"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   End With
   Next iSht
    Call Select_Cell_A1
    wb2.Sheets("Mapping").Visible = False
    wb2.SaveAs wb1.Path & "\" & "Name" & " - " & criterium & " - " & pre & ".xlsx", xlWorkbookDefault
    wb2.Close False
  Next criterium
  Application.ScreenUpdating = True
  MsgBox "All sheets have been created :)"
End Sub

 

[Alex Blakenburg]

Since you are just looping through the array you don't even need the transpose, so you just set the array to the rngCriteria.
So just use

arrCriteria = rngCriteria

Let me know if you can't work out how to fit it into your existing code.

 

[db2020]

Thanks Alex, can you show me where to fit it in the existing code?

 

[Alex Blakenburg]

Where you have this line:

criteria = Array("Name1", "Name2")

Replace it with these lines:-

  Dim shtCriteria As Worksheet
  Dim rngCriteria As Range

  Set shtCriteria = Worksheets("Sheet3")
  With shtCriteria
    Set rngCriteria = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    criteria = rngCriteria
  End With

 

[db2020]

You are a life saver, many thanks!

 

[Alex Blakenburg]

You're welcome. Glad I could help.