请大佬帮忙写根据条件创建或删除工作表

longwin

名可名非恒名 发表于 2024-8-17 12:30
大佬，我除了新员工名单,老员工,不能删1,不能删2,不能删3，这些工作表不能删以外，但是后期会增加表格， ...

有一个方法：把不能删除的工作表名称放在新员工名单里面

longwin

Qs18

Private Sub Workbook_Open()
Application.DisplayAlerts = False
Dim arr, i, dic As Object, sht As Worksheet
arr = Sheet1.Range("a1").CurrentRegion.Value
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For Each sht In Sheets
    dic(sht.Name) = ""
Next
For i = 2 To UBound(arr)
    s = arr(i, 1)
    If s <> Empty Then
    If Not dic.exists(s) Then
        Sheet2.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = arr(i, 1)
    End If
    End If
    dic2(s) = ""
Next
For j = Sheets.Count To 5 Step -1
    If Not dic2.exists(Sheets(j).Name) Then
        Sheets(j).Delete
    End If
Next
Application.DisplayAlerts = True
Set dic = Nothing: Set dic2 = Nothing
Set sht = Nothing
End Sub

Qs18

试试......

Qs18

试试............

jaxxcyh

1. Sub test()
   
2.     Dim sht As Worksheet
   
3.     Dim FindSht As Boolean
   
4.     Dim MyRow%
   
5.     MyRow = Sheets("新员工名单").[a1].End(xlDown).Row
   
6.    
   
7.     '添加新来的
   
8.     For i = 2 To MyRow
   
9.         FindSht = False
   
10.         For Each sht In Sheets
    
11.             If sht.Name = Sheets("新员工名单").Cells(i, 1).Value Then FindSht = True
    
12.         Next
    
13.         
    
14.         If Not FindSht Then
    
15.             Sheets("老员工").Copy after:=Sheets(Sheets.Count)
    
16.             Set sht = Sheets(Sheets.Count)
    
17.             sht.Name = Sheets("新员工名单").Cells(i, 1).Value
    
18.         End If
    
19.     Next
    
20.    
    
21.     '删除不在的
    
22.     Dim arrTmp() As String
    
23.    
    
24.     For i = Sheets.Count To 1 Step -1
    
25.         'Debug.Print sht.Name
    
26.         FindSht = False
    
27.         For j = 2 To MyRow
    
28.             If Sheets(i).Name = Sheets("新员工名单").Cells(j, 1).Value Then FindSht = True
    
29.         Next
    
30.         
    
31.         If Not FindSht Then  '如果扫描一遍员工名单没发现工作表名字在其中
    
32.                              '就进一步检查此工作表名字是否在不能删的工作表名字中
    
33.             arrTmp = Filter(Array("新员工名单", "老员工", "不能删1", "不能删2", "不能删3"), Sheets(i).Name)
    
34.             Application.DisplayAlerts = False
    
35.             If UBound(arrTmp) = -1 Then Sheets(i).Delete    '如果是空数组，说明此表可删
    
36.             Application.DisplayAlerts = True
    
37.         End If
    
38.     Next
    
39.    
    
40.     MsgBox "OK"
    
41. End Sub
    
42. 
    

复制代码

jaxxcyh

不能删的表名字可以在33行写到数组里，或者放在新员工名单最前面，不影响后续增减名单