Sub names2()
Dim NewName As String
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Nwb As Workbook
Dim wss As String, wbName As String
Dim i As Long, x As Long, s As Long
Dim sLines
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To wb.Worksheets.Count
wss = wss & "," & Worksheets(i).Range("C2")
Next
wss = Mid(wss, 2)
sLines = Split(wss, ",")
With CreateObject("Scripting.Dictionary")
For x = LBound(sLines) To UBound(sLines)
If Not IsMissing(sLines(x)) Then .Item(sLines(x)) = 1
Next
sLines = .Keys
End With
For s = 0 To UBound(sLines)
Set Nwb = Workbooks.Add
wbName = Application.Workbooks.Item(2).Name
wb.Activate
With wb
For i = 1 To .Worksheets.Count
If Worksheets(i).Range("C2") = sLines(s) Then
Worksheets(i).Copy Workbooks(wbName).Worksheets(3)
.Activate
End If
Next
End With
Workbooks(wbName).Activate
Workbooks(wbName).Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
NewName = InputBox("District " & sLines(s) & " Is Done." _
& vbCrLf & "Please Enter the name for the new workbook", "New Workbook Name")
With ActiveWorkbook
.SaveAs (NewName & ".xlsx")
.Close savechanges:=True
End With
Next
MsgBox "Operation Complete"
End Sub