Public Sub Split_Sheet_By_Location_MrE1613908_Mod()
'https://www.mrexcel.com/board/threads/get-only-text-from-inputbox-value.1221260
'2022-11-11, request to start Filtering leaving some rows above that row.
'Data starts in A1, so
Dim objCollection As Collection
Dim strPathNewFile As String
Dim strSaveFolder As String
Dim rngCell As Range
Dim rngStart As Range
Dim varKey As Variant
Dim varNewFile As Variant
Dim wsTargSheet As Worksheet
Dim lngAnswer As Long
Dim wb As Workbook
Dim wsWork As Worksheet
Const cstrLastSheetName As String = "Last Sheet to keep"
Const clngNumShKeep As Long = 3
Set wb = ThisWorkbook
If wb.Worksheets.Count > clngNumShKeep Then
lngAnswer = MsgBox("More than " & clngNumShKeep & " sheets in this workbook" & _
vbCrLf & "Do you want to delete them?", vbYesNo, "Delete sheets?")
Select Case lngAnswer
Case vbYes
lngAnswer = MsgBox("Do you want to delete them by hand?", vbYesNo, "How to delete?")
Select Case lngAnswer
Case vbYes
MsgBox "Please delete sheets manually and start macro again.", vbInformation, "Ending here"
GoTo end_here
Case vbNo
If Evaluate("ISREF('" & cstrLastSheetName & "'!A1)") Then
lngAnswer = MsgBox("Do you want to delete all sheets to the right of '" & _
cstrLastSheetName & "'?", vbYesNo, "Which sheets?")
Select Case lngAnswer
Case vbYes
Application.DisplayAlerts = False
Do While wb.Worksheets(wb.Worksheets.Count).Name <> cstrLastSheetName
wb.Worksheets(wb.Worksheets.Count).Delete
Loop
Application.DisplayAlerts = True
Case vbNo
lngAnswer = MsgBox("Keep all sheets and proceed?", vbYesNo, "Continue?")
Select Case lngAnswer
Case vbYes
'continue
Case vbNo
MsgBox "Ending macro here.", vbExclamation, "Stop procedure"
GoTo end_here
End Select
End Select
Else
lngAnswer = MsgBox("Do you want to delete all sheets from the right which exceed the index of '" & _
clngNumShKeep & "'?", vbYesNo, "Which sheets?")
Select Case lngAnswer
Case vbYes
Application.DisplayAlerts = False
Do While wb.Worksheets.Count > clngNumShKeep
wb.Worksheets(wb.Worksheets.Count).Delete
Loop
Application.DisplayAlerts = True
Case vbNo
lngAnswer = MsgBox("Keep all sheets and proceed?", vbYesNo, "Continue?")
Select Case lngAnswer
Case vbYes
'continue
Case vbNo
MsgBox "Ending macro here.", vbExclamation, "Stop procedure"
GoTo end_here
End Select
End Select
End If
End Select
Case vbNo
End Select
End If
lngAnswer = MsgBox("Do you want to export the created sheets to individual workbooks?", vbYesNo, "Export data?")
Application.ScreenUpdating = False
If lngAnswer = vbYes Then
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Choose a folder"
If .Show = -1 Then
strSaveFolder = .SelectedItems(1)
If Right(Trim(strSaveFolder), 1) <> "\" Then strSaveFolder = Trim(strSaveFolder) & "\"
Else
MsgBox "No folder selected", vbInformation, "Ending..."
GoTo end_here
End If
End With
End If
retry:
varNewFile = Application.InputBox("Enter Sheet Name", "Sheet Name", Type:=2)
If varNewFile = False Then
MsgBox "No sheet name entered", vbInformation, "Exit procedure"
GoTo end_here
Else
If Not Evaluate("ISREF('" & varNewFile & "'!A1)") Then
If MsgBox("Can't find sheet '" & varNewFile & "'." & vbCrLf & "Try Again or Cancel?", vbOKCancel, "Typo?..") = vbYes Then
GoTo retry
Else
GoTo end_here
End If
End If
End If
Set wsWork = wb.Worksheets(varNewFile)
With wsWork
If .AutoFilterMode Then .AutoFilterMode = False
Set objCollection = New Collection
On Error Resume Next
Set rngStart = Application.InputBox("Choose the starting cell in the sheet or enter address like 'A2'", "Start Cell", Type:=8)
If Err.Number <> 0 Then
MsgBox "No proper selection to start with", vbInformation, "Exit procedure"
GoTo end_here
End If
If lngAnswer = vbYes Then
varNewFile = Application.InputBox("Enter New File name", "New File", Type:=2)
If varNewFile = False Then
MsgBox "No new file name entered", vbInformation, "Exit procedure"
GoTo end_here
End If
End If
For Each rngCell In .UsedRange.Range(rngStart, .Cells(.Rows.Count, rngStart.Column).End(xlUp))
objCollection.Add rngCell.Value, CStr(rngCell.Value)
Next rngCell
Err.Clear
On Error GoTo 0
'Autofilter column A by each location and copy results to location sheet
For Each varKey In objCollection
If Not Evaluate("ISREF('" & CStr(varKey) & "'!A1)") Then
Set wsTargSheet = Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
wsTargSheet.Name = CStr(varKey)
Else
Set wsTargSheet = wb.Worksheets(CStr(varKey))
wsTargSheet.UsedRange.ClearContents
End If
If .AutoFilterMode Then .AutoFilterMode = False
.UsedRange.Rows(rngStart.Row - 1).AutoFilter Field:=rngStart.Column, Operator:=xlFilterValues, Criteria1:="=" & varKey 'Field:=1 means column A
.UsedRange.Copy wsTargSheet.Range("A1")
wsTargSheet.UsedRange.EntireColumn.AutoFit
If lngAnswer = vbYes Then
strPathNewFile = strSaveFolder & varNewFile & "_" & varKey & ".xlsx"
If Dir(strPathNewFile) <> "" Then Kill strPathNewFile
wsTargSheet.Copy
ActiveWorkbook.SaveAs strPathNewFile, FileFormat:=51
ActiveWorkbook.Close SaveChanges:=False
End If
Next varKey
'Remove autofilter
.UsedRange.AutoFilter
.Activate
End With
Application.ScreenUpdating = True
MsgBox "Done"
end_here:
Err.Clear
Set wsTargSheet = Nothing
Set rngStart = Nothing
Set wsWork = Nothing
Set wb = Nothing
End Sub
, Finally I closed this thread 
