Placement of For Loop

Damian37

Board Regular
Joined
Jun 9, 2014
Messages
241
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:

VBA Code:
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.
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,567
Office Version
  1. 2007
Platform
  1. Windows
Try this:

VBA Code:
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
 

Forum statistics

Threads
1,140,995
Messages
5,703,619
Members
421,306
Latest member
ambuj Thakur

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top