An addition to the code is missing - in each filter the file will be saved in a specific path, with the name consisting of:
1. Cell A1
2. Two months back from today,
3. A year - of the same month - that is, two months back from today in the year 2022
Every month runs the macro.
The result: saving the number of files as the number of filters in a specific path named month year (two months back) and cell A1
Option Explicit
Public Sub FilterByColumnA()
Dim ws As Worksheet
Set ws = Worksheets("SHBZ")
Dim tableRange As Range
Set tableRange = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
Dim item, Items
Items = UniqueItems(tableRange, vbTextCompare)
ws.Range("A1").AutoFilter
For Each item In Items
ws.Range("A1").AutoFilter field:=1, Criteria1:=item
SaveWorkbookToItem item.Value
Next item
Set ws = Nothing
Set tableRange = Nothing
End Sub
Private Function UniqueItems(ByVal r As Range, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _
Optional ByRef Count) As Variant
'Return an array with all unique values in R
' and the number of occurrences in Count
Dim Area As Range, Data
Dim i As Long, j As Long
Dim Dict As Object 'Scripting.Dictionary
Set r = Intersect(r.Parent.UsedRange, r)
If r Is Nothing Then
UniqueItems = Array()
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = Compare
For Each Area In r.Areas
Data = Area
If IsArray(Data) Then
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
If Not Dict.Exists(Data(i, j)) Then
Dict.Add Data(i, j), 1
Else
Dict(Data(i, j)) = Dict(Data(i, j)) + 1
End If
Next
Next
Else
If Not Dict.Exists(Data) Then
Dict.Add Data, 1
Else
Dict(Data) = Dict(Data) + 1
End If
End If
Next
UniqueItems = Dict.Keys
Count = Dict.Items
End Function
Private Sub SaveWorkbookToItem(item As String)
Const path = "C:\logs\"
ActiveWorkbook.SaveAs path & Format(Date - 30, "mm YYYY") & "SHBZ" & item & ".xlsx"
End Sub
1. Cell A1
2. Two months back from today,
3. A year - of the same month - that is, two months back from today in the year 2022
Every month runs the macro.
The result: saving the number of files as the number of filters in a specific path named month year (two months back) and cell A1
VBA Code:
Public Sub FilterByColumnA()
Dim ws As Worksheet
Set ws = Worksheets("SHBZ")
Dim tableRange As Range
Set tableRange = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
Dim item, Items
Items = UniqueItems(tableRange, vbTextCompare)
ws.Range("A1").AutoFilter
For Each item In Items
ws.Range("A1").AutoFilter field:=1, Criteria1:=item
SaveWorkbookToItem item.Value
Next item
Set ws = Nothing
Set tableRange = Nothing
End Sub
Private Function UniqueItems(ByVal r As Range, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _
Optional ByRef Count) As Variant
'Return an array with all unique values in R
' and the number of occurrences in Count
Dim Area As Range, Data
Dim i As Long, j As Long
Dim Dict As Object 'Scripting.Dictionary
Set r = Intersect(r.Parent.UsedRange, r)
If r Is Nothing Then
UniqueItems = Array()
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = Compare
For Each Area In r.Areas
Data = Area
If IsArray(Data) Then
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
If Not Dict.Exists(Data(i, j)) Then
Dict.Add Data(i, j), 1
Else
Dict(Data(i, j)) = Dict(Data(i, j)) + 1
End If
Next
Next
Else
If Not Dict.Exists(Data) Then
Dict.Add Data, 1
Else
Dict(Data) = Dict(Data) + 1
End If
End If
Next
UniqueItems = Dict.Keys
Count = Dict.Items
End Function
Private Sub SaveWorkbookToItem(item As String)
Const path = "C:\logs\"
ActiveWorkbook.SaveAs path & Format(Date - 30, "mm YYYY") & "SHBZ" & item & ".xlsx"
End Sub
