Sub CreateNewWbks() Dim dic As Object, rng As Range, wks As Worksheet, mypath As String, lr As Long Set dic = CreateObject("scripting.dictionary") Set wks = Sheet1 mypath = ThisWorkbook.Path & "\" lr = wks.Range("F" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False Application.DisplayAlerts = False With wks For nr = lr To 2 Step -1 If (Not dic.exists(.Cells(nr, "F").Value)) Then dic.Add .Cells(nr, "F").Value, .Cells(nr, "F").Value Set rng = .Range("A1:I" & .Cells(Rows.Count, 1).End(xlUp).Row) rng.AutoFilter field:=6, Criteria1:=.Range("F" & nr).Value rng.Copy Workbooks.Add ActiveSheet.Paste ActiveSheet.Columns.AutoFit ActiveSheet.[A1].Select ActiveWorkbook.SaveAs Filename:=mypath & .Range("F" & nr).Value & ".xlsx" ActiveWorkbook.Close End If Next .AutoFilterMode = False End With MsgBox "All Done!", vbExclamation Application.CutCopyMode = False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
Member requests are more likely to be responded to.
Members can monitor the statuses of their requests from their account pages.
A CCM membership gives you access to additional options.