VBA to auto filter data based on department and copy into new workbook

[ChanL]

I have a set of data where need to filter based on department value (i.e. department 1 , department 2) and after filtered, I will need to copy the data together with my header in row 1 and row 2 into a new workbook and rename it with the department name. The code need to be loop through the unique value of column D for all the unique department name.

Here are the code I written, it able to create new workbook bt it didn't copy only data for that particular department, in fact it copy the whole thing and just turn on the filter

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim filterRange As Range
    Dim filteredData As Range
    Dim departmentCell As Range
    Dim newWorkbook As Workbook
    Dim newFilePath As String
    
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    
    ' Set the range to be filtered based on the department column
    Set filterRange = ws.Range("D4").CurrentRegion
    filterRange.AutoFilter Field:=4, Criteria1:="<>"
    
    ' Loop through each unique department
    For Each departmentCell In ws.Range("D4", ws.Range("D" & ws.Rows.Count).End(xlDown)).SpecialCells(xlCellTypeVisible)
        ' Copy the filtered data
        ws.Copy
        ' Create a new workbook and paste the filtered data as values
        Set newWorkbook = Workbooks.Add
        newWorkbook.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
        ' Rename the new workbook with the department value
        newWorkbook.SaveAs wb.Path & "\" & departmentCell.Value & ".xlsx"
        newWorkbook.Close SaveChanges:=False
    Next departmentCell
    
    Application.ScreenUpdating = False
    
    ' Clear the filters
    filterRange.AutoFilter
    
    ' Activate the original workbook
    wb.Activate

End Sub

 

[jkpieterse]

You are close.
If you assume the list does not contain duplicate departments, then this should work:

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim filterRange As Range
    Dim filteredData As Range
    Dim departmentCell As Range
    Dim newWorkbook As Workbook
    Dim newFilePath As String
   
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
   
    ' Set the range to be filtered based on the department column
    Set filterRange = ws.Range("D4").CurrentRegion
   
    ' Loop through each unique department
    For Each departmentCell In ws.Range("D4", ws.Range("D" & ws.Rows.Count).End(xlDown)).SpecialCells(xlCellTypeVisible)
       
        filterRange.AutoFilter Field:=4, Criteria1:=departmentCell.Value
       
        ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
       
        ' Create a new workbook and paste the filtered data as values
        Set newWorkbook = Workbooks.Add
        newWorkbook.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
        ' Save the new workbook with the department value
        newWorkbook.SaveAs wb.Path & "\" & departmentCell.Value & ".xlsx"
        newWorkbook.Close SaveChanges:=False
    Next departmentCell
   
    Application.ScreenUpdating = False
   
    ' Clear the filters
    filterRange.AutoFilter
   
    ' Activate the original workbook
    wb.Activate

End Sub