Placement of For Loop

[Damian37]

Hello All,
I have the following code that is working, however, there are a total of 15 regions within the country. I would like this code repeated all the way through until the last region has been saved. At that point I would like to end the For Loop. My issue is I'm not entirely sure where I should place the For Loop. Here's the code I have thus far:

Sub FilterDataCopyPasteSave()
'
' FilterDataCopyPasteSave Macro
' Filter by Region; copy data; paste in new workbook; save new workbook
'

'
   Dim TableSheet As Worksheet
   Dim NewWB As Workbook
  
   Set TableSheet = Worksheets("AllData")
  
   With TableSheet
  
      .ListObjects("Table6").Range.AutoFilter Field:=3, Criteria1:="Region Name"
      .ListObjects("Table6").Range.AutoFilter Field:=5, Criteria1:="Open*"
      .ListObjects("Table6").Range.AutoFilter Field:=4, Criteria1:=Array("CSC", "SX", "XM; 2.5", "XM; 2.6", "XM; 3", "XR", "XM; 1", "XM; 2", "Mall Kiosk", "XM", "Kiosk", "3.0", "XR Lite", "Legacy Pre-Paid", "Pop Up", "Pop-Up", "PR", "Sat Loc 3351"), Operator:=xlFilterValues
      
      .Range("Table6[[#Headers],[Store Id]]").Select
      .Range(Selection, Selection.End(xlToRight)).Select
      .Range(Selection, Selection.End(xlDown)).Select
  
   End With
  
   Selection.Copy
   Set NewWB = Workbooks.Add
  
   With NewWB.Worksheets(1)
      .Paste
      Application.CutCopyMode = False
      .Cells.EntireColumn.AutoFit
   End With
  
   NewWB.SaveAs Filename:="C:\Users\NTLogin\Desktop\POC Validation-Request\Non-BP POC Region " & Format(Date, "mm.dd.yyyy") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
    
    
End Sub

Any and all help is welcome. Thank you very much!

D.

 

[DanteAmor]

.ListObjects("Table6").Range.AutoFilter Field:=3, Criteria1:="Region Name"

In column 3 of the table are the regions?
Or where are they?

 

[Damian37]

In column 3 of the table are the regions?
Or where are they?

Yes, Column 3 is where the region names are located.

 

[DanteAmor]

Try this:

Sub FilterDataCopyPasteSave()
' FilterDataCopyPasteSave Macro
' Filter by Region; copy data; paste in new workbook; save new workbook
'
  Dim TableSheet As Worksheet
  Dim NewWB As Workbook
  Dim dic As Object, ky As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set TableSheet = Worksheets("AllData")
  Set dic = CreateObject("Scripting.Dictionary")
  
  With TableSheet.ListObjects("Table6")
    For i = 1 To .DataBodyRange.Rows.Count
      dic(.DataBodyRange(i, 3).Value) = Empty
    Next
    For Each ky In dic.keys
      .Range.AutoFilter Field:=3, Criteria1:=ky
      .Range.AutoFilter Field:=5, Criteria1:="Open*"
      .Range.AutoFilter Field:=4, Criteria1:=Array("CSC", "SX", "XM; 2.5", "XM; 2.6", "XM; 3", _
            "XR", "XM; 1", "XM; 2", "Mall Kiosk", "XM", "Kiosk", "3.0", "XR Lite", _
            "Legacy Pre-Paid", "Pop Up", "Pop-Up", "PR", "Sat Loc 3351"), Operator:=xlFilterValues
      .AutoFilter.Range.Copy
      
      Set NewWB = Workbooks.Add
      NewWB.Sheets(1).Paste
      NewWB.Sheets(1).Cells.EntireColumn.AutoFit
      NewWB.SaveAs Filename:="C:\Users\NTLogin\Desktop\POC Validation-Request\" & _
          "Non-BP POC Region " & ky & " " & Format(Date, "mm.dd.yyyy") & ".xlsx", _
          FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
      NewWB.Close False
    Next
    .Range.AutoFilter
  End With
  Application.CutCopyMode = False
End Sub