Need to extract cells to  a new workbooks based on a unique criteria in a certain column

Sub ExportData()
Dim cel As Range, rg As Range, rgcopy As Range, rgData As Range, rgFilters As Range
Dim wb As Workbook
Dim flPath As String
flPath = Application.GetSaveAsFilename(ActiveWorkbook.FullName, FileFilter:="Excel workbooks (*.xlsx), *.xlsx", _
    Title:="Pick any workbook in the desired folder, then click 'Save'")
If flPath = "False" Then Exit Sub
Application.ScreenUpdating = False
flPath = Left(flPath, InStrRev(flPath, Application.PathSeparator))
With Worksheets("Table")
    Set rg = .Range("DF_Grid_1")
    Set rgData = rg.Offset(1, 0).Resize(rg.Rows.Count - 1, rg.Columns.Count)
    Set rgFilters = .Range("AP16")
    Set rgFilters = Range(rgFilters, rgFilters.End(xlDown))
End With
rgData.Cells(1, 1).AutoFilter
For Each cel In rgFilters
    If cel.Value <> "" Then
        rgData.AutoFilter Field:=2, Criteria1:=cel.Value
        Set rgcopy = rgData.SpecialCells(xlCellTypeVisible)
        If (rgcopy.Rows.Count > 1) Or (rgcopy.Areas.Count > 1) Then
            Set wb = Workbooks.Add
            rg.Copy ActiveSheet.Cells(1, 1)
            wb.SaveAs flPath & cel.Value & ".xlsx", FileFormat:=51
            wb.Close SaveChanges:=False
        End If
    End If
Next
rgData.AutoFilter Field:=2
End Sub

Select all Open in new window