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

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

行动我希望macros做：

1）如果一个表名匹配一个数组值，什么也不做
2）如果没有数组的值，请创build“模板”表的副本，并使用数组值重命名。 此外，复制表单的单元格A1作为数组值。
3）如果数组中不存在表单，请删除表单。 除了名为“input”或“模板”的图纸外。

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

代码以添加工作表：

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）如何添加重命名单元格A1的块与AddSheet代码中的数组值？

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

3）如何将这些代码合并成一个代码，最后在input表中创build一个button来激活这个macros？

提前谢谢了！

Answer 1

干得好。 您要做的第一件事是在模块的顶部添加Option Compare Text以与Like Operator配合使用。 我必须使用Range（“A”和Rows.Count）来赞扬你。结束（xlUp）.Row这是我最喜欢的find最大行的方法。 作为一个更好的做法，我build议将所有Dim语句放在每个Sub的顶部。

我select首先执行删除操作，因为在过程中员工列表不会改变，但是要添加的工作表的数量可以减less。 加快你可以，对不对？ 下面的代码将从input工作表中的B列（不包括B1）中获取员工姓名。 我将input和模板工作表名称分配为常量，因为它们通过代码多次使用。 这样，如果你决定给他们打电话，你不是通过代码寻找。

即使这些过程已经在这里合并了，我们也可以很容易地从第一个调用另一个过程 ，把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