实际上利用Range对象的RemoveDuplicates()方法会问这个问题：
Option Explicit
Sub AddSheets()
Dim myCell As Range
Dim Cities As Range
With Sheets("AllCities")
Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
Cities.RemoveDuplicates Columns:=Array(1), Header:=xlNo '<~~ remove duplicates
End With
For Each myCell In Cities
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = myCell.Value
Next myCell
End Sub
只要您不在乎所有重复值都会永远丢失！
但它会留下两个未处理的重要例外：
1) 在宏执行之前已经存在的工作表的重复名称
2) 工作表名称中的无效字符
您可以处理那些具有专用功能的功能，这些功能将为后续步骤开绿灯，如下所示：
Option Explicit
Sub AddSheets()
Dim myCell As Range
Dim Cities As Range
With Sheets("AllCities")
Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
Cities.RemoveDuplicates Columns:=Array(1), Header:=xlNo '<~~ remove duplicates from list
End With
For Each myCell In Cities
If CheckSheetName(myCell.Value) Then '<~~ check for invalid sheet name...
If CheckSheetDuplicate(ActiveWorkbook, myCell.Value) Then '<~~ ... if valid name then check for duplicates in existent sheets...
Sheets.Add After:=Sheets(Sheets.Count) '<~~ ... if no duplicates sheets then finally add a new sheet...
ActiveSheet.Name = myCell.Value'<~~ ... and give it proper name
End If
End If
Next myCell
End Sub
Function CheckSheetName(shtName As String) As Boolean
Dim invalidChars As Variant
Dim myChar As Variant
invalidChars = Array(":", "/", "\", "?", "*", "[", "]")
'check shtName for forbidden characters
CheckSheetName = True
For Each myChar In invalidChars
If InStr(shtName, myChar) > 0 Then
CheckSheetName = False
Exit For
End If
Next myChar
End Function
Function CheckSheetDuplicate(wb As Workbook, shtName As String) As Boolean
CheckSheetDuplicate = True '<~~ set positive check result. it'll be turned to negative in case of problems ..
On Error Resume Next
CheckSheetDuplicate = wb.Sheets(shtName) Is Nothing '<~~ set negative check result in case of problems from any attempt to use a sheet with given name: for instance trying and use it as an object
End Function
当然，您可以进一步增强检查功能并拥有它们：
-
更正名称
例如删除无效字符
-
承认重复
例如在它的 and 处添加一个重复名称计数器
最后，这是一个非常大胆的子代码，它（希望）有意识地利用错误处理删除来避免检查并得到最终结果
Sub BoldlyAddSheets()
Dim myCell As Range
Dim Cities As Range
Dim mysht As Worksheet
Dim currentShtName As String
With Sheets("AllCities")
Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
End With
Application.DisplayAlerts = False '<~~ necessary not to have macro interrupted by any prompts risen by possible Delete() method over sheet objects
On Error Resume Next '<~~ ignore errors -> you must know what you are doing till the next "On Error GoTo 0" statement!
For Each myCell In Cities
Set mysht = Sheets(myCell.Value) '<~~ try setting a sheet object with the current cell value and ...
If mysht Is Nothing Then '<~~ ...if unsuccessful then there's no sheet with the wanted name already, so let's try adding it
Sheets.Add After:=Sheets(Sheets.Count) '<~~ 1) add a new sheet
currentShtName = ActiveSheet.Name '<~~ 2) store new sheet default name, to check for things to possibly go wrong...
ActiveSheet.Name = myCell.Value '<~~ 3) try setting the new name...
If ActiveSheet.Name = currentShtName Then ActiveSheet.Delete '<~~ ...if unsuccessful (sheet name with forbidden characters) delete the sheet
Else
Set mysht = Nothing '<~~ set it back to Nothing for subsequent loops
End If
Next myCell
Application.DisplayAlerts = True '<~~ at long last ... turn default alerts handling on...
On Error GoTo 0 '<~~ ... and turn default error handling on, too. this latter just for clarity since "On Error GoTo 0" is automatically done at exiting any sub or function
End Sub