VBA to filter Worksheet on manager column & copy all data to new workbook

[kizzie37]

Hi, I'm not a VBA person, but tried to take a stab piecing together bits from other posts, but didn't do too well.

I have a worksheet Range A - Z.
Column C is filled with manager names (multiple entries of same manager name as each line represents an employee who reports to a manager, Multiple employees per manager)
I need the code to filter the list by each manager, copy the range for each and paste into a separate workbook (not as values, as is). then save the workbook as "Text workbook & Manager Name)
loop through all managers and do this for every manager on the list.

I cant save a test file here because security wont allow this or upload of code. Below is what I pieced together, I know its not correct, but some of the elements work.

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim FilterRange As Range
    Dim filteredData As Range
    Dim managerCell As Range
    Dim newWorkbook As Workbook
    Dim newFilePath As String
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FieldNum As Integer
    Dim mailAddress As String
    Dim strbody As String
    Dim DefaultSignature As String
  
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet
  
    'Set filter range and filter column (Column with names)
    Set FilterRange = Ash.Range("A1:Z" & Ash.Rows.Count)
    FieldNum = 3
    
    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Ash.Columns(3))
    'If there are unique values start the loop
        If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Ash.Cells(Rnum, 1).Value
    
    
        'Add a worksheet for the unique list and copy the unique list in A1
    Set newWorkbook = Workbooks.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Ash.Range("A1"), _
            CriteriaRange:="", Unique:=True
            

        newWorkbook.Worksheets(1).Range("A1").Paste Paste:=xlPaste
        ' Save the new workbook with the department value
        newWorkbook.SaveAs wb.Path & "\" & "Compensation Increase Master Sheet" & ".xlsx"
        newWorkbook.Close SaveChanges:=False
    
        Next Rnum
  
    Application.ScreenUpdating = False
  

    'Close AutoFilter
    Ash.AutoFilterMode = False

    ' Activate the original workbook
    wb.Activate
    End If
    
End Sub

 

[dragontbone]

It looks like you are on the right track. If I understand what you are looking for, you may want to try this.

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim UniqueManagers As Range
    Dim ManagerName As Range
    Dim Manager As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long

    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet

    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("C:C")
    FieldNum = 1

    ' Find the last row in the filter range
    LastRow = FilterRange.Find(What:="*", After:=FilterRange.Cells(1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    ' Create a list of unique manager names
    Set UniqueManagers = Ash.Range("C2:C" & LastRow).AdvancedFilter(Unique:=True)

    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers.Rows
        Manager = ManagerName.Value

        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Manager

        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add

        ' Copy the visible cells (filtered data) to the new workbook
        Ash.UsedRange.SpecialCells(xlCellTypeVisible).Copy

        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste

        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & Manager & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False

        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True

End Sub

This code should filter the data by manager names, copy the filtered data, create a new workbook for each manager, paste the data into the new workbook, and save it with the manager's name. It loops through all unique manager names in your data and performs these steps for each manager.

 

[kizzie37]

It looks like you are on the right track. If I understand what you are looking for, you may want to try this.

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim UniqueManagers As Range
    Dim ManagerName As Range
    Dim Manager As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long

    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet

    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("C:C")
    FieldNum = 1

    ' Find the last row in the filter range
    LastRow = FilterRange.Find(What:="*", After:=FilterRange.Cells(1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    ' Create a list of unique manager names
    Set UniqueManagers = Ash.Range("C2:C" & LastRow).AdvancedFilter(Unique:=True)

    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers.Rows
        Manager = ManagerName.Value

        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Manager

        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add

        ' Copy the visible cells (filtered data) to the new workbook
        Ash.UsedRange.SpecialCells(xlCellTypeVisible).Copy

        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste

        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & Manager & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False

        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True

End Sub

This code should filter the data by manager names, copy the filtered data, create a new workbook for each manager, paste the data into the new workbook, and save it with the manager's name. It loops through all unique manager names in your data and performs these steps for each manager.

Thanks for this, its erroring on :

 Set UniqueManagers = Ash.Range("C2:C" & LastRow).AdvancedFilter(Unique:=True)

"Unable to get AdvancedFilter property of the Range class"

?

 

[dragontbone]

Try this:

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim Dict As Object

    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet

    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("C:C")
    FieldNum = 1

    ' Find the last row in the filter range
    LastRow = Ash.Cells(Ash.Rows.Count, "C").End(xlUp).Row

    ' Create a dictionary to store unique manager names
    Set Dict = CreateObject("Scripting.Dictionary")

    ' Loop through the manager names and add them to the dictionary
    For Each ManagerNameCell In FilterRange.Range("C2:C" & LastRow)
        ManagerName = ManagerNameCell.Value
        If Not Dict.Exists(ManagerName) Then
            Dict(ManagerName) = True
        End If
    Next ManagerNameCell

    ' Get the unique manager names from the dictionary
    Set ManagerNames = Ash.Range("AA1").Resize(Dict.Count, 1)
    i = 0
    For Each Key In Dict.Keys
        ManagerNames.Cells(i + 1, 1).Value = Key
        i = i + 1
    Next Key

    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerNameCell In ManagerNames.Rows
        ManagerName = ManagerNameCell.Value

        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName

        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add

        ' Copy the visible cells (filtered data) to the new workbook
        Ash.UsedRange.SpecialCells(xlCellTypeVisible).Copy

        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste

        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False

        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerNameCell

    Application.ScreenUpdating = True

End Sub

 

[kizzie37]

Try this:

Sub FilterCopyPaste()

    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim Dict As Object

    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet

    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("C:C")
    FieldNum = 1

    ' Find the last row in the filter range
    LastRow = Ash.Cells(Ash.Rows.Count, "C").End(xlUp).Row

    ' Create a dictionary to store unique manager names
    Set Dict = CreateObject("Scripting.Dictionary")

    ' Loop through the manager names and add them to the dictionary
    For Each ManagerNameCell In FilterRange.Range("C2:C" & LastRow)
        ManagerName = ManagerNameCell.Value
        If Not Dict.Exists(ManagerName) Then
            Dict(ManagerName) = True
        End If
    Next ManagerNameCell

    ' Get the unique manager names from the dictionary
    Set ManagerNames = Ash.Range("AA1").Resize(Dict.Count, 1)
    i = 0
    For Each Key In Dict.Keys
        ManagerNames.Cells(i + 1, 1).Value = Key
        i = i + 1
    Next Key

    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerNameCell In ManagerNames.Rows
        ManagerName = ManagerNameCell.Value

        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName

        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add

        ' Copy the visible cells (filtered data) to the new workbook
        Ash.UsedRange.SpecialCells(xlCellTypeVisible).Copy

        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste

        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False

        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerNameCell

    Application.ScreenUpdating = True

End Sub

Thanks, unfortunately all that's happening is its creating new workbooks and only copying the header from the master workbook tot he new workbook and nothing else, it also is naming the file based on a value in column E. I dont see a filter being applied at all to the master.

 

[dragontbone]

How about this one?

Sub FilterCopyPaste()
    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim UniqueManagers As Collection
    
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet
    
    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("A1:Z" & Ash.Cells(Rows.Count, "A").End(xlUp).Row)
    FieldNum = 3
    
    ' Find the last row in the filter range
    LastRow = FilterRange.Rows.Count
    
    ' Create a collection to store unique manager names
    Set UniqueManagers = New Collection
    
    ' Loop through the manager names and add them to the collection
    On Error Resume Next
    For i = 2 To LastRow
        UniqueManagers.Add FilterRange.Cells(i, FieldNum).Value, CStr(FilterRange.Cells(i, FieldNum).Value)
    Next i
    On Error GoTo 0
    
    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers
        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add
        
        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName
        
        ' Copy the visible cells (filtered data) to the new workbook
        FilterRange.SpecialCells(xlCellTypeVisible).Copy
        
        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste
        
        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False
        
        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True
End Sub

I made several changes to the code to address the issues you mentioned. Here are the key changes:

1. Changed the range for FilterRange to span columns A to Z and find the last row in column A to determine the range.
2. Modified the code to collect unique manager names using a Collection instead of a dictionary.
3. Used the SpecialCells method to copy visible (filtered) cells, which should fix the issue of only copying the header.
4. Corrected the filename used for saving workbooks to be based on the manager's name.

These changes should ensure that the code filters the data correctly, copies the visible cells, and saves the workbooks with the manager's name.

 

[kizzie37]

How about this one?

Sub FilterCopyPaste()
    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As String
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim UniqueManagers As Collection
   
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet
   
    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("A1:Z" & Ash.Cells(Rows.Count, "A").End(xlUp).Row)
    FieldNum = 3
   
    ' Find the last row in the filter range
    LastRow = FilterRange.Rows.Count
   
    ' Create a collection to store unique manager names
    Set UniqueManagers = New Collection
   
    ' Loop through the manager names and add them to the collection
    On Error Resume Next
    For i = 2 To LastRow
        UniqueManagers.Add FilterRange.Cells(i, FieldNum).Value, CStr(FilterRange.Cells(i, FieldNum).Value)
    Next i
    On Error GoTo 0
   
    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers
        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add
       
        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName
       
        ' Copy the visible cells (filtered data) to the new workbook
        FilterRange.SpecialCells(xlCellTypeVisible).Copy
       
        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste
       
        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False
       
        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True
End Sub

I made several changes to the code to address the issues you mentioned. Here are the key changes:

1. Changed the range for FilterRange to span columns A to Z and find the last row in column A to determine the range.
2. Modified the code to collect unique manager names using a Collection instead of a dictionary.
3. Used the SpecialCells method to copy visible (filtered) cells, which should fix the issue of only copying the header.
4. Corrected the filename used for saving workbooks to be based on the manager's name.

These changes should ensure that the code filters the data correctly, copies the visible cells, and saves the workbooks with the manager's name.

Thank you, this results in a "compile error" "For each control variable must be Variant or Object" on

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers

 

[dragontbone]

Sorry about that. Maybe this will work?

Sub FilterCopyPaste()
    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As Variant 
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim UniqueManagers As Collection
    
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet
    
    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("A1:Z" & Ash.Cells(Rows.Count, "A").End(xlUp).Row)
    FieldNum = 3
    
    ' Find the last row in the filter range
    LastRow = FilterRange.Rows.Count
    
    ' Create a collection to store unique manager names
    Set UniqueManagers = New Collection
    
    ' Loop through the manager names and add them to the collection
    On Error Resume Next
    For i = 2 To LastRow
        UniqueManagers.Add FilterRange.Cells(i, FieldNum).Value, CStr(FilterRange.Cells(i, FieldNum).Value)
    Next i
    On Error GoTo 0
    
    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers
        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add
        
        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName
        
        ' Copy the visible cells (filtered data) to the new workbook
        FilterRange.SpecialCells(xlCellTypeVisible).Copy
        
        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste
        
        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False
        
        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True
End Sub

 

[kizzie37]

Sorry about that. Maybe this will work?

Sub FilterCopyPaste()
    Dim wb As Workbook
    Dim Ash As Worksheet
    Dim FilterRange As Range
    Dim ManagerNames As Range
    Dim ManagerNameCell As Range
    Dim ManagerName As Variant
    Dim NewWorkbook As Workbook
    Dim NewWorksheet As Worksheet
    Dim NewFilePath As String
    Dim Rcount As Long
    Dim FieldNum As Integer
    Dim LastRow As Long
    Dim UniqueManagers As Collection
   
    ' Set the workbook and worksheet variables
    Set wb = ThisWorkbook
    Set Ash = wb.ActiveSheet
   
    ' Set filter range and filter column (Column with manager names)
    Set FilterRange = Ash.Range("A1:Z" & Ash.Cells(Rows.Count, "A").End(xlUp).Row)
    FieldNum = 3
   
    ' Find the last row in the filter range
    LastRow = FilterRange.Rows.Count
   
    ' Create a collection to store unique manager names
    Set UniqueManagers = New Collection
   
    ' Loop through the manager names and add them to the collection
    On Error Resume Next
    For i = 2 To LastRow
        UniqueManagers.Add FilterRange.Cells(i, FieldNum).Value, CStr(FilterRange.Cells(i, FieldNum).Value)
    Next i
    On Error GoTo 0
   
    Application.ScreenUpdating = False

    ' Loop through each unique manager name
    For Each ManagerName In UniqueManagers
        ' Create a new workbook
        Set NewWorkbook = Workbooks.Add
       
        ' Filter the data for the current manager
        FilterRange.AutoFilter Field:=FieldNum, Criteria1:=ManagerName
       
        ' Copy the visible cells (filtered data) to the new workbook
        FilterRange.SpecialCells(xlCellTypeVisible).Copy
       
        ' Add a new worksheet to the new workbook
        Set NewWorksheet = NewWorkbook.Worksheets.Add
        NewWorksheet.Paste
       
        ' Save the new workbook with the manager's name
        NewFilePath = wb.Path & "\Text workbook " & ManagerName & ".xlsx"
        NewWorkbook.SaveAs Filename:=NewFilePath
        NewWorkbook.Close SaveChanges:=False
       
        ' Clear the filter
        Ash.AutoFilterMode = False
    Next ManagerName

    Application.ScreenUpdating = True
End Sub

Works perfectly! thank you so much for your help with this, much appreciated!