Option Explicit
Sub TheMassCopier()
Dim TheCityRange As Range, Cell As Range
Dim TheFileName As String
Dim TheFilePath As String
Dim i As Integer
TheFilePath = ThisWorkbook.Path
With Sheets('TheCities')
Set TheCityRange = .Range('B2:B' & .Range('B1000').End(xlUp).Row)
End With
For Each Cell In TheCityRange
TheFileName = Cell
If Not TheFileName = '' Then
ThisWorkbook.SaveCopyAs TheFilePath & '\\' & TheFileName & '.xls'
End If
Next
End Sub