Save extracted files in current directory and more.

[allanjones863]

I need the code below to save as an xlsb file in the current directory (same as original file), also need to be able to select the column to create workbooks (set as column 4 below), need input dialog to select which column. Further would like the new file to filtered.

Thank You




Sub PrepareFiles()
Dim DistDic As Object
Set DistDic = CreateObject("Scripting.Dictionary")
Dim WkRg As Range, Rg As Range
Dim K
Dim WkP As String
Application.ScreenUpdating = False
WkP = ActiveWorkbook.Path
Set WkRg = ActiveSheet.UsedRange
ActiveSheet.AutoFilterMode = False
For Each Rg In WkRg.Columns(4).Cells.Offset(1)
If (Rg <> "") Then DistDic.Item(Rg.Value) = Empty
Next Rg
For Each K In DistDic.keys
With WkRg
.AutoFilter Field:=4, Criteria1:=K
End With
Workbooks.Add
WkRg.SpecialCells(xlCellTypeVisible).Copy Destination:=Cells(1, 1)
Cells.EntireColumn.AutoFit
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Fpath & "\" & FName & ".xlsb", FileFormat:=50
Application.DisplayAlerts = True
ActiveWorkbook.Close
Next K
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox ("Job Done")
End Sub

 

[allanjones863]

Need assistance, please.

VBA code modification assistance​