Sub SaveSpecificSheet()
' Defines variables
Dim ws As Worksheet, wsSheet As Worksheet, wsName As String, fPath As String, Cell As Range, cRange As Range
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Disables alerts to prevent popups
Application.DisplayAlerts = False
' Defines the output filepath
fPath = "C:\TestFolder"
' On error continue
On Error Resume Next
' Set the desired sheet name to save individually as the value entered in text box
wsName = (InputBox("Enter sheet name"))
' Set wsSheet as the specified sheet name
Set wsSheet = Sheets(wsName)
' On error exit
On Error GoTo 0
' If the specified sheet exists then...
If Not wsSheet Is Nothing Then
' Set LastRow as the last row of column F
LastRow = Sheets(wsName).Cells(Rows.Count, "F").End(xlUp).Row
' Set the check range as F1 to the last row of F
Set cRange = Sheets(wsName).Range("F1:F" & LastRow)
' For each cell in the check range
For Each Cell In cRange
With ThisWorkbook
Dim wb As Workbook
' Create a new workbook
Set wb = Application.Workbooks.Add
' Delete Sheets 2 and 3 of the new workbook
wb.Sheets(Array(2, 3)).Delete
' Copy the specified sheet of the source workbook and put it in front of Sheet1 of the new workbook
ThisWorkbook.Sheets(wsName).Copy Before:=wb.Sheets(1)
' Delete the last blank sheet from the new workbook
wb.Sheets(2).Delete
' Save the new workbook to the specified filepath named the corresponding cell value
wb.SaveAs Filename:=fPath & "\" & Cell.Value & ".xlsx"
' Close the new workbook
wb.Close
End With
' Check next cell in check range
Next Cell
' Display a message that the specified sheet has been saved to individual workbooks
MsgBox wsName & " saved as individual workbooks based on column F to " & fPath
' Else if the specified sheet does not exist or you cancel the input box then...
Else
' Display an error that the specified sheet does not exist
MsgBox "Specified sheet does not exist"
End If
' Re-enables screen updating
Application.ScreenUpdating = True
' Re-enables alerts
Application.DisplayAlerts = True
End Sub