Try this on a COPY of your data.
You will need to state the name of the source and destination worksheets at the top of the code where indicated.
Previous workbook with the same name will be deleted before the new workbook is created..
No sorting yet. What do you want to sort on and just in the destination sheet?
VBA Code:
Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String
' **** Change reference to the sheet containing the data. ****
Set Ws = Worksheets("AccountManagers")
' **** Set the destination sheet name. ****
strDestinationSheet = "Data"
ActiveWorkbook.Save
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
strPath = fncSelectFolder
If strPath = "" Then
Exit Sub
End If
Ws.Activate
last = Ws.Cells(Rows.Count, "C").End(xlUp).Row
arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")
Set rng = Ws.Range("A2:E" & last)
Application.DisplayAlerts = False
For i = LBound(arr) To UBound(arr)
With rng
.AutoFilter Field:=3, Criteria1:=arr(i, 1)
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Range("A1").PasteSpecial xlPasteAll
ActiveSheet.Copy
With ActiveSheet
.Name = strDestinationSheet
.Cells.EntireColumn.AutoFit
.Cells(1, 1).Select
End With
On Error Resume Next
Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
On Error GoTo 0
With ActiveWorkbook
.SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
.Close
End With
Ws.Activate
Wb.Sheets(Sheets.Count).Delete
.AutoFilter
End With
Next i
Application.DisplayAlerts = True
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"
End Sub
Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Destination Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Function
End If
myFolder = .SelectedItems(1) & "\"
End With
fncSelectFolder = myFolder
End Function
Thank you. I have amended to this, but I get an runtime error 1004
Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String
' **** Change reference to the sheet containing the data. ****
Set Ws = Worksheets("TTT")
' **** Set the destination sheet name. ****
strDestinationSheet = "DATA"
ActiveWorkbook.Save
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
strPath = fncSelectFolder
If strPath = "" Then
Exit Sub
End If
Ws.Activate
last = Ws.Cells(Rows.Count, "C").End(xlUp).Row
arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")
Set rng = Ws.Range("A3:N" & last)
Application.DisplayAlerts = False
For i = LBound(arr) To UBound(arr)
With rng
.AutoFilter Field:=3, Criteria1:=arr(i, 1)
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Range("A1").PasteSpecial xlPasteAll
ActiveSheet.Copy
With ActiveSheet
.Name = strDestinationSheet
.Cells.EntireColumn.AutoFit
.Cells(1, 1).Select
End With
On Error Resume Next
Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
On Error GoTo 0
With ActiveWorkbook
.SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
.Close
End With
Ws.Activate
Wb.Sheets(Sheets.Count).Delete
.AutoFilter
End With
Next i
Application.DisplayAlerts = True
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"
End Sub
Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Destination Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Function
End If
myFolder = .SelectedItems(1) & "\"
End With
fncSelectFolder = myFolder
End Function