Excel添加工作表

我需要根据名为AllCities的工作表中名称列表创build一个子工作表。 城市名称列表从A2单元格开始。 工作表需要按照列表中的单元格值来命名，并且不应该创build任何重复的工作表。 这是我迄今为止：

Sub addsheets() Dim myCell As Range Dim Cities As Range With Sheets("AllCities") Set Cities = Sheets("AllCities").Range("A2") Set Cities = Range(Cities, Cities.End(xlDown)) End With For Each myCell In Cities If Not myCell.Value = vbNullString Then Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = myCell.Value End If Next myCell End Sub 

Answer 1

看起来问题在于确保重复项不会被创build。 我可以想出两种方法来做到这一点，但select了我认为对这种情况最有效的方法。

1. 记住名字 （select） – 记住string中可以很快检查的工作表的名称，如果你在成千上万个标签中有大量（25+以上）的城市名称，那么这将不是最好的解决scheme，但是在那个时候我怀疑你会有不同的问题要考虑。
2. 创build一个执行检查的error handling过程 – 您可以调用第二个过程来检查表单是否存在，这会减慢处理时间，但是如果大规模使用则会更安全。

下面是你的代码，检查重复包括。

 Sub addsheets() Dim myCell As Range Dim Cities As Range Dim StrSheets As String Dim WkSht As Excel.Worksheet With ThisWorkbook.Worksheets("AllCities") Set Cities = Range(.Range("A2"), .Range("A2").End(xlDown)) End With StrSheets = "|" For Each WkSht In ThisWorkbook.Worksheets StrSheets = StrSheets & WkSht.Name & "|" Next For Each myCell In Cities If Not myCell.Value = vbNullString Then If InStr(1, StrSheets, "|" & myCell.Value & "|") = 0 Then Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = myCell.Value StrSheets = StrSheets & myCell.Value & "|" End If End If Next myCell End Sub 

Answer 2

如果你不想要任何重复，那么最好的办法是删除重复。 如果您希望原始图纸不变，请创build图纸的副本，然后删除重复项并创build图纸。

Answer 3

实际上利用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）与macros执行前已经存在的工作表有关的重复名称

2）表名中的字符无效

你可以用专门的function来处理那些会给后续步骤提供绿色照明的function，如下所示：

 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 

当然你可以在检查function方面做进一步的改进，并让它们：

• 改正名字

  例如删除无效的字符

• 承认重复

  例如在其中添加一个重复的名称计数器

最后这里是一个非常大胆的子（希望）有意识地利用error handling删除来避免检查并得到最终结果

 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 

Answer 4

基于两个假设的附加变体，第一个是具有城市的单元格的范围可能包含重复项，第二个是对于在范围中列出的一些城市，该表格已经被添加。

 Sub addsheets() Dim myCell As Range, Cities As Range, Dic As Object, sh As Worksheet, k Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = vbTextCompare With Sheets("AllCities") Set Cities = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row) End With For Each myCell In Cities 'if value is non blank and not duplicated in a range of cells then add to dictionary If myCell.Value2 <> "" And Not Dic.exists(myCell.Value2) Then Dic.Add CStr(myCell.Value2), Nothing End If Next myCell For Each sh In ThisWorkbook.Sheets 'if sheet with name listed in Cities already exists then remove name from dictionary If Dic.exists(sh.Name) Then Dic.Remove (sh.Name) Next sh For Each k In Dic 'add sheets with unique values stored in dictionary Sheets.Add(After:=Sheets(Sheets.Count)).Name = k Next k End Sub