Excel VBA: Loop through autofilter criteria to copy and paste to new sheet then save as new file.

[alantse2010]

Hi all,
I want to loop through autofilter criteria in column G( below photo) to copy and paste to new sheet then save as new file.

Below is my code, i know that it can use if and else to do, i want to know how to change to use the loop.
Thank you very much for your help.

Dim wb As Workbook
Dim wsw As Worksheet
Dim y As Workbook
Dim lastRow, lastRow2 As Long
Dim readsheetName As String
Dim destsheetName As String
Dim fso As Object, FolDir As String, FileNm As Object, NumStr As Integer, MaxNum As Integer
Dim NewName As String, StrNum As String, MaxStr As String
Dim FolderStr As String 'Object
MaxNum = 1
FolderStr = "Q:\Alan\VBA\CCA\"
'Set fso = CreateObject("scripting.filesystemobject")
'Set FolDir = fso.GetFolder(FolderStr)
FolDir = Dir(FolderStr)

readsheetName = "2011-2019"
destsheetName = "Cable Collection Advices (2)"
Set wb = ThisWorkbook
Set wsw = wb.Sheets(readsheetName)

wsw.Activate

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Filtered Data").Delete


On Error GoTo 0
Application.DisplayAlerts = True
 Application.ScreenUpdating = False
Set wsDest = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
 wsDest.Name = "Filtered Data"
MM1
wsw.Range("A1:U1").AutoFilter Field:=7, Criteria1:="296699"
wsw.Range("A1:U1").AutoFilter Field:=14, Criteria1:="Available", Operator:=xlOr, Criteria2:="="
If wsw.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
 
  wsw.Cells.SpecialCells(xlCellTypeVisible).Copy
   wsDest.Activate
   wsDest.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
  
   wsDest.Columns("N:U").Delete
   wsDest.Columns("A:B").Delete
   wsDest.Columns("F").Delete
   wsDest.Rows(1).Delete
    lastRow = wsDest.Range("A" & Rows.Count).End(xlUp).Row
   Set SourceRange = wsDest.Range("A1:D" & lastRow)
   Set SourceRange2 = wsDest.Range("F1:G" & lastRow)
   Set SourceRange3 = wsDest.Range("E1:E" & lastRow)
   Set SourceRange4 = wsDest.Range("J1:J" & lastRow)
   SourceRange.Copy
   Set y = Workbooks.Open("\\SSSSNNMR20\EAS2EAS1\75 ABCDE Engineering\76 CABLE Engineering - General\PE-Test-ABCDE\E_P\02 AB\Alan\VBA\CCA\Cable Collection Advices - 11.xls")
   y.Sheets(destsheetName).Range("C8").PasteSpecial xlPasteValues
   SourceRange2.Copy
   y.Sheets(destsheetName).Range("G8").PasteSpecial xlPasteValues
   SourceRange3.Copy
   y.Sheets(destsheetName).Range("I8").PasteSpecial xlPasteValues
   SourceRange4.Copy
   y.Sheets(destsheetName).Range("J8").PasteSpecial xlPasteValues
   lastRow2 = wsDest.Range("C" & Rows.Count).End(xlUp).Row
   y.Sheets(destsheetName).Range("A8:A" & lastRow2 + 7).Value = Format(Now(), "dd.mm.yyyy")
   y.Sheets(destsheetName).Range("B5").Value = Format(Now(), "dd.mm.yyyy")
   Application.DisplayAlerts = False
   Do While Len(FolDir) > 0
   If FolDir Like "Cable Collection Advices - " & "*" & ".xlsx" Then
   StrNum = Right(Left(FolDir, 32), 5)
   'MsgBox "StrNum" & StrNum
    NumStr = CInt(StrNum)
    If NumStr > MaxNum Then
    MaxNum = NumStr
    End If
    End If
    FolDir = Dir
    'Next FileNm
    Loop
    MaxStr = CStr(Format(MaxNum + 1))
    NewName = FolderStr & "Cable Collection Advices - " & MaxStr & ".xlsx"
    y.SaveAs Filename:=NewName, FileFormat:=51, CreateBackup:=False
   y.Close SaveChanges:=False
   ActiveWorkbook.Worksheets("Filtered Data").Delete
   wsw.Activate
   MM1
Else
  MsgBox ("No data")
End If

Sub MM1() 'close all the worksheet autofilter
Dim ws As Worksheet
For Each ws In Worksheets
 'ws.AutoFilterMode = ShowAllData
    With ws
        If .AutoFilterMode Then
            If .FilterMode Then
            .ShowAllData
            End If
        End If
    End With
Next ws
End Sub

 

[alantse2010]

push