Excel添加工作表

Question

我需要创建一个sub，根据名为AllCities的工作表中的名称列表创建工作表。城市名称列表从单元格A2开始。工作表需要以列表中的单元格值命名，并且不应创建任何重复的工作表。这就是我到目前为止所做的：

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

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

1. 记住名称（已选择） - 请记住字符串中可以快速检查的工作表名称，如果您拥有大型（长度超过25个）城市，则不是最佳解决方案数以千计的标签名称，但在那时我怀疑你会有不同的问题需要考虑。
2. 创建一个执行检查的错误处理过程 - 您可以调出第二个过程来检查是否存在工作表，这会缩短处理时间，但如果使用会更安全大规模的。

以下是您的代码，其中包含重复检查的内容。

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

如果您不想要任何重复，那么最好的方法就是删除副本。如果您希望原始工作表保持不变，则创建工作表的副本，然后删除重复项并创建工作表。

Answer 3

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

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

Answer 4

实际上利用RemoveDuplicates() Range对象的方法会问这个问题：

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

当然，您可以在检查功能方面做进一步的改进，并拥有它们：

• 更正名称

  例如删除无效字符

• 承认重复

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

最后，这是一个非常大胆的子（希望）有意识地利用错误处理删除来避免检查并获得最终结果

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