Excel VBA filter value then copy filtered data to new worksheet

This Excel VBA tutorial explains how to automate AutoFilter to filter value and then copy data to new worksheet or copy data to new workbook.

You may also want to read:

Excel VBA copy each worksheet to new workbook

Access VBA auto generate mass report by group to Excel

Filter value then copy filtered data to new worksheet

I find it very difficult to come up with a suitable title and key words for this post. I will try to describe what this Macro does with an example.

Suppose you have a staff list as below.

Now you want to create one worksheet for each department.

Worksheet “HR”

Department	Staff ID	Name
HR	1	Peter
HR	2	Apple
HR	3	Banana

Worksheet “IT”

Department	Staff ID	Name
IT	2	John
IT	6	Judy

Worksheet “CS”

Department	Staff ID	Name
CS	4	Cat
CS	5	David

If you have a hundred of unique department, it will take you forever to manually copy the data over to the new worksheet. What I want to achieve is to create a Macro to automatically filter each department and then copy the contents to a new worksheet.

VBA Code – Filter value then copy filtered data to new worksheet

To use this Macro:

1) Copy and paste the below code in a Module

2) Modify the 3rd row of code where the targetCol is the column that contains the department you want to break into separate worksheets

3) Select the worksheet that contains the staff list

4) Run the Macro

Public Sub FilterThenCopy()
   Dim ws, newWS, currentWS As Worksheet
   targetCol = 1   'define which column you want to break
   Dim objDict As Variant
   Set objDict = CreateObject("Scripting.Dictionary")
   Set currentWS = ActiveSheet
   'Add unique value in targetCol to the dictionary
   Application.DisplayAlerts = False
   For r = 2 To Cells(Rows.Count, targetCol).End(xlUp).Row
     If Not objDict.exists(Cells(r, targetCol).Value) Then
       objDict.Add Cells(r, targetCol).Value, Cells(r, targetCol).Value
     End If
   Next r

  If currentWS.AutoFilterMode = True Then
     currentWS.UsedRange.AutoFilter
  End If
  currentWS.UsedRange.AutoFilter
  For Each k In objDict.Keys
    currentWS.UsedRange.AutoFilter field:=targetCol, Criteria1:=objDict.Item(k)
   'delete worksheet if worksheet of item(k) exist
    For Each ws In ActiveWorkbook.Worksheets
      If wsExists(objDict.Item(k)) Then
        Sheets(objDict.Item(k)).Delete
      End If
    Next ws
   'crate worksheet using item(k) name
    Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    newWS.Name = objDict.Item(k)
    'copy filtered contents to new worksheet
    currentWS.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    newWS.Range("A1").Select
    newWS.Paste
  Next k
  currentWS.Activate
  currentWS.AutoFilterMode = False
  Application.DisplayAlerts = True
End Sub

Function wsExists(wksName As String) As Boolean
   On Error Resume Next
   wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
   On Error GoTo 0
End Function

Result

After you run the Macro, 3 new worksheets are created. The format should also be copied from the master staff list.

Filter value then copy to new workbook

Instead of copying data to new worksheet, you may want to copy to new workbook. Previously I wrote a post about copying each worksheet to new workbook, you just need to run the above Macro, and then run the copy to new workbook Macro. Click here to read my previous post.

Use Microsoft Access to generate mass report by Group

If you want to achieve the same result using Microsoft Access, click here to read my previous post. The advantage of using Microsoft Access is that you can use Query to transform data before export.