Excel VBA to filter by unique value, copy paste into new workbook and save

[rittersportyummy]

Hi All, excel VBA noob here. sorry if im not clear as my english isnt that great.

I am trying to create a macro that will help with filtering unique value and copying them into a new workbook and saving them as value based on filtered name. details as below:

• i have around 8000 rows of data
• to filter value based on cell G5 onwards - example i have value apple, banana, coconut etc etc
• copy paste columns A:M with filtered data (example apple) as value to a new workbook - column A1:M5 is my template header, row 5 is formulated with subtotal formula
• save this excel workbook and name it: filtered value + month - apple <month>
• and whole cycle repeats by filtering next unique value from my working data sheet - banana... coconut and so on.
• file to save into the same path as per my working data sheet

some images as below for clearer explanation:

raw data:

raw data filtered:

copy and paste as value whole data + header into new workbook, and save as "apple May'24)

 

[John_w]

Try this macro.

Public Sub Split_Sheet_By_Unique_Names()
    
    Dim destFolder As String
    Dim DistinctNames As Variant, DistinctName As Variant
    Dim filteredCells As Range
    Dim NameWorkbook As Workbook
    Dim AutoFilterWasOn As Boolean
    
    destFolder = ThisWorkbook.Path & "\"
    
    Application.ScreenUpdating = False

    With ActiveWorkbook.Worksheets("DATA")
            
        AutoFilterWasOn = .AutoFilterMode

        'Read distinct names from G6 down
        
        DistinctNames = Application.WorksheetFunction.Unique(.Range("G6:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Value)
        
        For Each DistinctName In DistinctNames
    
            'Filter on column G to show only rows for this Name

            .Range("A5:M5").AutoFilter Field:=7, Operator:=xlFilterValues, Criteria1:="=" & DistinctName
            Set filteredCells = .UsedRange.SpecialCells(xlCellTypeVisible)
            
            'Copy filtered cells to new workbook
            
            Set NameWorkbook = Workbooks.Add(xlWBATWorksheet)
            filteredCells.Copy NameWorkbook.Worksheets(1).Range("A1")
            NameWorkbook.Worksheets(1).Range("A1").CurrentRegion.EntireColumn.AutoFit
            Application.DisplayAlerts = False 'suppress warning if file already exists
            NameWorkbook.SaveAs destFolder & DistinctName & " " & .Range("D1").Text & ".xlsx", xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            NameWorkbook.Close False
            
        Next
    
        'Restore autofilter if it was on
        
        .AutoFilter.ShowAllData
        If Not AutoFilterWasOn Then .AutoFilterMode = False
        
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub

 

[rittersportyummy]

Omg John_W, thank you so much for this!!! it works!!!!!!!!!!!!!!!! grateful for your help!!! thank you!!