Filter VBA to sheets

G

gleamng

Board Regular
Joined
Oct 8, 2016
Messages
98
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
  9. 2003 or older
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Good day everyone, the code below is a credited to @DanteAmor, though i made a little unprofessional editing on it to suit my need. However, i want this vba to also save all sheets as workbook excempting "Sheet1" after filtering to sheets.

thanking you all for your continued support.

VBA Code: 
Option Explicit

Sub Filter()
    Dim sht As Worksheet
    Dim a As Variant, ky As Variant
    Dim rng As Range
    Dim dic As Object
    Dim i As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
    Set dic = CreateObject("scripting.dictionary")
    Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
    a = rng.Value
    
    For i = 2 To UBound(a, 1)
        dic(a(i, 4)) = Empty
    Next
    
    For Each ky In dic.keys
        On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
        
        rng.AutoFilter
        rng.AutoFilter field:=4, Criteria1:=ky
        sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
        Range("A2").PasteSpecial (xlPasteAll)
        Range("A:A,C:D").Delete
        Range("A1").Value = ("VER NO.")
        Range("B1").Value = UCase(ky)
        Columns("A:B").EntireColumn.AutoFit
        Range("A1").Select
    Next
    
    'Turn off filter
    sht.Activate
    sht.AutoFilterMode = False
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
Hi @gleamng .
Thanks for posting on MrExcel

gleamng said:
i want this vba to also save all sheets as workbook excempting "Sheet1"
Click to expand...
Try this:

VBA Code: 
Sub Filter()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Dim wb As Workbook
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
  Set dic = CreateObject("scripting.dictionary")
  Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
  a = rng.Value
  
  For i = 2 To UBound(a, 1)
    dic(a(i, 4)) = Empty
  Next
  
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
    
    rng.AutoFilter
    rng.AutoFilter field:=4, Criteria1:=ky
    sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
    Range("A2").PasteSpecial (xlPasteAll)
    Range("A:A,C:D").Delete
    Range("A1").Value = ("VER NO.")
    Range("B1").Value = UCase(ky)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
  Next
  
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
  
  'copy sheets
  Sheets.Copy
  Set wb = ActiveWorkbook
  wb.Sheets("Sheet1").Delete
  wb.SaveAs ThisWorkbook.Path & "\" & "New workbook.xlsx", xlOpenXMLWorkbook
  wb.Close False
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Thanks a lot for your quick response always.
The vba worked but i wasn't detailed enough, i want each sheet be saved as a workbook and saving each file with its sheet name. Thanks once again
 
Upvote 0
gleamng said:
, i want this vba to also save all sheets as workbook excempting "Sheet1" after filtering to sheets.
Click to expand...
👆

gleamng said:
i wasn't detailed enough, i want each sheet be saved as a workbook
Click to expand...
:cool:
Then try this:

VBA Code: 
Sub Filter()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Dim wb As Workbook
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
  Set dic = CreateObject("scripting.dictionary")
  Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
  a = rng.Value
  
  For i = 2 To UBound(a, 1)
    dic(a(i, 4)) = Empty
  Next
  
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
    
    rng.AutoFilter
    rng.AutoFilter field:=4, Criteria1:=ky
    sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
    Range("A2").PasteSpecial (xlPasteAll)
    Range("A:A,C:D").Delete
    Range("A1").Value = ("VER NO.")
    Range("B1").Value = UCase(ky)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
    Sheets(ky).Copy
    Set wb = ActiveWorkbook
    wb.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
    wb.Close
  Next
  
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
DanteAmor said:
👆


:cool:
Then try this:

VBA Code: 
Sub Filter()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Dim wb As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
  Set dic = CreateObject("scripting.dictionary")
  Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
  a = rng.Value
 
  For i = 2 To UBound(a, 1)
    dic(a(i, 4)) = Empty
  Next
 
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
  
    rng.AutoFilter
    rng.AutoFilter field:=4, Criteria1:=ky
    sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
    Range("A2").PasteSpecial (xlPasteAll)
    Range("A:A,C:D").Delete
    Range("A1").Value = ("VER NO.")
    Range("B1").Value = UCase(ky)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
    Sheets(ky).Copy
    Set wb = ActiveWorkbook
    wb.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
    wb.Close
  Next
 
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
 
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Thank you so much, it worked perfectly well, lastly i want the files to be saved in a folder named current date ("yyyy mmm") in a folder name VAR on desktop.
I tried this line but failed
wb.SaveAs "C:
DanteAmor said:
👆


:cool:
Then try this:

VBA Code: 
Sub Filter()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Dim wb As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
  Set dic = CreateObject("scripting.dictionary")
  Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
  a = rng.Value
 
  For i = 2 To UBound(a, 1)
    dic(a(i, 4)) = Empty
  Next
 
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
   
    rng.AutoFilter
    rng.AutoFilter field:=4, Criteria1:=ky
    sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
    Range("A2").PasteSpecial (xlPasteAll)
    Range("A:A,C:D").Delete
    Range("A1").Value = ("VER NO.")
    Range("B1").Value = UCase(ky)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
    Sheets(ky).Copy
    Set wb = ActiveWorkbook
    wb.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
    wb.Close
  Next
 
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
 
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Thank you so much, it worked fine and lastly i edited the vba to what i have below but it failed.
i want the files to be saved in a folder with current month format ("yyyy mmm") to be created inside a folder on desktop named VER. below is what i have that failed.

Sub Filter()
Dim sht As Worksheet
Dim a As Variant, ky As Variant
Dim rng As Range
Dim dic As Object
Dim i As Long
Dim wb As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set sht = Sheets("Sheet1") 'Specify sheet name where data is resident
Set dic = CreateObject("scripting.dictionary")
Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
a = rng.Value

For i = 2 To UBound(a, 1)
dic(a(i, 4)) = Empty
Next

For Each ky In dic.keys
On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0

rng.AutoFilter
rng.AutoFilter field:=4, Criteria1:=ky
sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
Sheets.Add(after:=Sheets(Sheets.Count)).Name = ky
Range("A2").PasteSpecial (xlPasteAll)
Range("A:A,C:D").Delete
Range("A1").Value = ("VER NO.")
Range("B1").Value = UCase(ky)
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
'Copy VBA with reference to wb, ky
Sheets(ky).Copy
Set wb = ActiveWorkbook
'wb.SaveAs ThisWorkbook.Path & "\" & ky & " .xlsx", xlOpenXMLWorkbook
wb.SaveAs "C:\Users\GLOBAL-BEAM\Desktop\VER\" & Format(Now(), "yyyy mmm") & " Upload\" & ky & " .xlsx", xlOpenXMLWorkbook
wb.Close
Next

'Turn off filter
sht.Activate
sht.AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
 
Upvote 0
gleamng said:
i want the files to be saved in a folder with current month format ("yyyy mmm") to be created inside a folder on desktop named VER
Click to expand...
That was not included in your original post. :unsure:

Do you want the file name to have the date?
Or do you want the folder name to have the date?

Put an image here to see the folder name and I adapt the code to match the folder name you have on your machine.
 
Upvote 0
i want the files to be saved in a FOLDER with current date format "yyyy mmm" which be created inside a folder on desktop named VAR

thank you.

below is a code i use separetely before seeking you assistance
VBA Code: 
Sub SheetsToWorkbooks()
      Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
      MyFilePath$ = "C:\Users\GLOBAL-BEAM\Desktop\VER\" & Format(Now(), "yyyy mmm") & " Upload"
      With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            '      End With
            On Error Resume Next    '<< a folder exists
            MkDir MyFilePath            '<< create a folder
            For N = 1 To Sheets.Count
                  Sheets(N).Activate
                  SheetName = ActiveSheet.Name
                  Cells.Copy
                  Workbooks.Add (xlWBATWorksheet)
                  With ActiveWorkbook
                        With .ActiveSheet
                              .Paste
                              .Name = SheetName
                              [A1].Select
                        End With
                        'save book in this folder
                        .SaveAs Filename:=MyFilePath & "\" & SheetName & ".xls"
                        .Close SaveChanges:=True
                  End With
                  .CutCopyMode = False
            Next
      End With
End Sub
 
Upvote 0
gleamng said:
i want the files to be saved in a FOLDER with current date format "yyyy mmm" which be created inside a folder on desktop named VAR
Click to expand...
According to your examples it should be "VER".
There must be a folder with this name:
C:\Users\GLOBAL-BEAM\Desktop\VER\2023 jun Upload
Click to expand...

Note: You must have administrator permissions to save files in the Users\GLOBAL-BEAM folder.

Try this:
Rich (BB code): 
Sub Filter()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Dim wb As Workbook
  Dim myPath As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  myPath = "C:\Users\GLOBAL-BEAM\Desktop\VER\" & Format(Now(), "yyyy mmm") & " Upload"
  If Dir(myPath, vbDirectory) = "" Then
    MsgBox "Path does not exists"
    Exit Sub
  End If
  
  Set sht = Sheets("Sheet1")          'Specify sheet name where data is resident
  Set dic = CreateObject("scripting.dictionary")
  Set rng = sht.Range("A1:E" & sht.Cells(Rows.Count, "D").End(xlUp).Row)
  a = rng.Value
  
  For i = 2 To UBound(a, 1)
    dic(a(i, 4)) = Empty
  Next
  
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
    
    rng.AutoFilter
    rng.AutoFilter field:=4, Criteria1:=ky
    sht.AutoFilter.Range.Offset(2).Resize(, 5).Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = ky
    Range("A2").PasteSpecial (xlPasteAll)
    Range("A:A,C:D").Delete
    Range("A1").Value = ("VER NO.")
    Range("B1").Value = UCase(ky)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
    Sheets(ky).Copy
    Set wb = ActiveWorkbook
    wb.SaveAs myPath & "\" & ky & ".xlsx", xlOpenXMLWorkbook
    wb.Close
  Next
  
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub
 
Upvote 0
Solution
Thank you so so much
Best wishes
 
Upvote 0
You must log in or register to reply here.

Similar threads

U
  • Solved
Rewrite Code as a Sub to work on Active Sheet
Replies
2
Views
53
Skyybot
Skyybot
R
  • Question Question
VBA Help Needed - Need code to only Copy Rows to existing Multiple worksheet when Column T<>X and ignore/not copy when X=Y
Replies
1
Views
544
DanteAmor
DanteAmor
C
  • Solved
Sum final column after creating worksheet
Replies
4
Views
100
cdrobinson83
C
A
  • Solved
VBA Autofilter partial match in two column
Replies
4
Views
516
alantse2010
A
S
  • Question Question
CSV export to remove column
Replies
1
Views
650
StellarRumble59
S

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

Share this page

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
Back
Top