VBA: add and remove sheets from a list
I am working on a piece of code that creates a copy of a specific template sheet or deletes a sheet based on the content of a column in an Excel sheet starting at cell B2.
Actions I would like to do Macro:
1) If the sheet name matches the array value, do nothing
2) If there is no sheet for the array value, create a copy of the template sheet and rename it with the array value. Also, the cell name A1 of the copied worksheet as an array value.
3) If there is a sheet that does not exist in the array, remove the sheet. Except for sheets named Input or Template.
So far, I have two separate codes, one for copying sheets and the other for deleting sheets:
Code for adding 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 for deleting 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:
1) How do I add an item that renames cell A1 with an array value in the AddSheet code?
2) How to add exclusion rules to the DeleteSheet code?
3) How can I combine these codes into one code and finally create a button to activate this macro in the input sheet?
Thank you very much in advance!
source to share
Here you go. The first thing you need to do is add Option Compare Text at the top of the module for use with Like Operator . I owe you a compliment by using Range ("A" and Rows.Count) .End (xlUp) .Row This is my favorite method for finding max row. As a best practice, I recommend placing all Dim statements at the top of each Sub.
I decided to do the delete first, because the Employee List will not change during the procedure, but the number of worksheets it needs to execute can be reduced for additions. Speed up where you can, right? The code below will grab the employee names from column B (excluding B1) from the input table. I assigned the names of worksheets and templates as constants as they are reused through the code. That way, if you ever decide to call them something else, you won't be looking for code.
Even if the procedures are already merged here, we could easily call another procedure from the 1st by putting DeleteSheet as the last line of AddSheet () This does not require using Call at the beginning. It was in the early days of Visual Basic, but it hasn't been for a long time. Let me know if something is unclear or doesn't work as you like.
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
source to share