Question

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

我希望宏执行的操作：

1）如果工作表名称与数组值匹配，则不执行任何操作 2）如果没有数组值表，请创建模板表的副本并使用数组值重命名。此外，将复制的纸张的单元格A1命名为数组值 3）如果阵列中不存在工作表，请删除工作表。除了名为Input或Template的工作表。

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

代码以便添加工作表：

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

代码以删除工作表：

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

我的问题是：

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

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

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

非常感谢提前！

Answer 1

你走了。您要做的第一件事是在模块顶部添加选项比较文字，以便与Like Operator一起使用。我必须使用 Range（＆＃34; A＆＃34;＆amp; Rows.Count）来赞美你.End（xlUp）.Row 这是我最喜欢的查找最大行的方法。作为一种更好的做法，我建议将所有Dim语句放在每个Sub的顶部。

我选择首先执行删除操作，因为员工列表在过程中不会发生变化，但是为了添加，可以减少它必须循环的工作表数量。加快你的速度，对吧？下面的代码将从输入工作表中获取B列中的员工姓名（不包括B1）。我将输入和模板工作表名称指定为常量，因为它们在代码中多次使用。这样，如果您决定将其称为其他内容，那么您就不会通过代码进行搜索。

即使程序已在此处合并，我们也可以轻松called another procedure from the 1st将 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

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

1 个答案: