VBA：从列表中添加和删除工作表

VBA: Add and delete sheets from list

提问by Klaberbem

I am working on a piece of code that creates a copy of a certain Template sheet or deletes a sheet based on the contents of a column in an Excel Sheet, starting in cell B2.

我正在处理一段代码，该代码创建某个模板工作表的副本或根据 Excel 工作表中一列的内容删除工作表，从单元格 B2 开始。

Actions I would like the Macro to do:

我希望宏执行的操作：

1) If a sheet name matches an array value do nothing
2) If there is no sheet for an array value, create a copy of the Template sheet and rename with the array value. Further, name cell A1 of the copied sheet as the array value.
3) If there is a sheet that does not exist in the array, delete the sheet. Except for the sheets named Input or Template.

1) 如果工作表名称与数组值匹配，则什么都不做
2) 如果没有用于数组值的工作表，请创建模板工作表的副本并使用数组值重命名。此外，将复制的工作表的单元格 A1 命名为数组值。
3) 如果数组中存在不存在的工作表，则删除该工作表。除了名为 Input 或 Template 的工作表。

Up to now I have two separate codes, one to copy sheets and the other to delete sheets:

到目前为止，我有两个单独的代码，一个用于复制工作表，另一个用于删除工作表：

Code in order to add sheets:

添加工作表的代码：

Sub AddSheet()
    Application.ScreenUpdating = False
    Dim bottomA As Integer
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
    For Each c In Range("A1:A" & bottomA)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.name = c.Value
        End If
    Next c
    Application.ScreenUpdating = True
    End Sub

Code in order to delete sheets:

用于删除工作表的代码：

Sub DeleteSheet()
Dim i As Long, x, wsAct As Worksheet
Set wsAct = ActiveSheet
For i = Sheets.Count To 1 Step -1
    If Not Sheets(i) Is wsAct Then
        x = Application.Match(Sheets(i).name, wsAct.Range("A1:A20"), 0)
        If IsError(x) Then
            Application.DisplayAlerts = False
            Sheets(i).Delete
            Application.DisplayAlerts = True
        End If
    End If
    Next i
    End Sub

My questions are:

我的问题是：

1) How can I add the piece that renames cell A1 with the array value in the AddSheet code?

1) 如何在 AddSheet 代码中添加使用数组值重命名单元格 A1 的片段？

2) How can I add the except rules in the DeleteSheet code?

2）如何在DeleteSheet代码中添加except规则？

3) How can I combine these codes into one code and finally create a button to activate this macro in the Input sheet?

3) 如何将这些代码组合成一个代码，并最终在输入表中创建一个按钮来激活此宏？

Many thanks in advance!

提前谢谢了！

采纳答案by David Rachwalik

Here you go. The first thing you'll want to do is add Option Compare Textat the top of the module for use with the Like Operator. I must compliment you using Range("A" & Rows.Count).End(xlUp).RowThat's my favorite method for finding max row. As a better practice, I recommend placing all Dim statements at the top of each Sub.

干得好。您要做的第一件事是在模块顶部添加Option Compare Text以与Like Operator 一起使用。我必须赞美你使用Range("A" & Rows.Count).End(xlUp).Row这是我最喜欢的查找最大行的方法。作为更好的做法，我建议将所有 Dim 语句放在每个 Sub 的顶部。

I chose to run through deletions first because the Employee List won't change during the procedure, but the number of worksheets it'll have to loop through can be reduced for the additions. Speed up where you can, right? The code below will grab Employee Names from Column B (excluding B1) from Input worksheet. I assigned Input and Template worksheet names as constants since they're used many times through the code. That way if you ever decide to call them something else, you're not hunting through code.

我选择先执行删除操作，因为员工列表在此过程中不会更改，但可以减少添加时必须循环的工作表数量。尽可能加快速度，对吗？下面的代码将从输入工作表的 B 列（不包括 B1）中获取员工姓名。我将输入和模板工作表名称指定为常量，因为它们在代码中被多次使用。这样，如果您决定将它们称为其他名称，您就不会在寻找代码。

Even though the procedures are already merged here, we could have easily called another procedure from the 1stby placing DeleteSheetas the last line of AddSheet()This does not require the use of Callin the beginning. It was in the early days of Visual Basic but hasn't been for a long time now. Let me know if anything is unclear or not working as you like.

即使这些过程已经在这里合并，我们也可以通过将DeleteSheet作为AddSheet()的最后一行来轻松地从第一个过程调用另一个过程。这不需要在开始时使用Call。它是在 Visual Basic 的早期，但现在已经不长一段时间了。如果有任何不清楚或不按您的意愿工作，请告诉我。

Sub CheckSheets()
    Dim wksInput As Worksheet
    Dim wks As Worksheet
    Dim cell As Range
    Dim MaxRow As Long
    Dim NotFound As Boolean
    Dim Removed As String
    Dim Added As String

    'Assign initial values
    Const InputName = "Input"
    Const TemplateName = "Template"
    Set wksInput = Worksheets(InputName)
    MaxRow = wksInput.Range("B" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False

    'Delete worksheets that don't match Employee Names or are not Input or Template
    For Each wks In Worksheets
        NotFound = True
        'Keep Input and Template worksheets safe
        If Not (wks.Name Like InputName Or wks.Name Like TemplateName) Then
            'Check all current Employee Names for matches
            For Each cell In wksInput.Range("B2:B" & MaxRow)
                If wks.Name Like cell Then
                    NotFound = False
                    Exit For
                End If
            Next cell
        Else
            NotFound = False
        End If
        'Match was not found, delete worksheet
        If NotFound Then
            'Build end message
            If LenB(Removed) = 0 Then
                Removed = "Worksheet '" & wks.Name & "'"
            Else
                Removed = Removed & " & '" & wks.Name & "'"
            End If
            'Delete worksheet
            Application.DisplayAlerts = False
            wks.Delete
            Application.DisplayAlerts = True
        End If
    Next wks

    'Check each Employee Name for existing worksheet, copy from template if not found
    For Each cell In wksInput.Range("B2:B" & MaxRow)
        NotFound = True
        For Each wks In Worksheets
            If wks.Name Like cell Then
                NotFound = False
                Exit For
            End If
        Next wks
        'Employee Name wasn't found, copy template
        If NotFound And LenB(Trim(cell & vbNullString)) <> 0 Then
            'Build end message
            If LenB(Added) = 0 Then
                Added = "Worksheet '" & cell & "'"
            Else
                Added = Added & " & '" & cell & "'"
            End If
            'Add the worksheet
            Worksheets(TemplateName).Copy After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = cell
            ActiveSheet.Range("A1") = cell
        End If
    Next cell

    'Added here so user sees worksheets when the message displays
    Application.ScreenUpdating = True

    'Final message touchups and display to user
    If LenB(Removed) <> 0 And LenB(Added) <> 0 Then
        Removed = Removed & " has been removed from the workbook." & vbNewLine & vbNewLine
        Added = Added & " has been added to the workbook."
        MsgBox Removed & Added, vbOKOnly, "Success!"
    ElseIf LenB(Removed) <> 0 Then
        Removed = Removed & " has been removed from the workbook."
        MsgBox Removed, vbOKOnly, "Success!"
    ElseIf LenB(Added) <> 0 Then
        Added = Added & " has been added to the workbook."
        MsgBox Added, vbOKOnly, "Success!"
    End If
End Sub