VB编辑中每次自动生成几个sheet

①然如故

问题解决了，在ThisWorkbook 添加 删除，验证下拉菜单单元格。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheet3.[b2:h2].Validation.Delete  
    Sheet3.[b3:h3].Validation.Delete   
End Sub
在此要特别感谢lsc900707的

耐心帮助

，以及chxw68，maditate两位老师。

求高手赐教，工作簿VB编辑器中多了几个sheet及工作表中的格式被自动清除，符上附件供测试。 VB多了sheet.rar (1.41 MB, 下载次数: 13)

2019-3-14 21:13 上传

点击文件名下载附件

打开时

lsc900707

可能误操作了吧，选定有用的工作表另存工作簿试试。

①然如故

lsc900707 发表于 2019-3-14 21:36
可能误操作了吧，选定有用的工作表另存工作簿试试。

lsc900707您好，我已尝试过另存为，还是没用的，请您帮查看是否VBA代码有问题，谢谢！

lsc900707

①然如故 发表于 2019-3-14 21:58
lsc900707您好，我已尝试过另存为，还是没用的，请您帮查看是否VBA代码有问题，谢谢！

哪几个是多的呢？原来就有sheet6吗？

①然如故

lsc900707 发表于 2019-3-14 22:20
哪几个是多的呢？原来就有sheet6吗？

lsc900707你好，原来只有5个表，见图

表名称栏也只显示5个，VB编辑器中每次打开在关闭都会成倍生成sheet.
VBA代码是用在“小单位汇总”

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Address <> "$B$2" And Target.Address <> "$B$3" Then Exit Sub 'And Target.Address <> "$B$4" Then Exit Sub
   
4.     Rem  ?????к??к?
   
5.     Dim C As Object, d As Object, Rng As Range, ss$, n%
   
6.     Set C = CreateObject("scripting.dictionary")
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     For Each Rng In Range("B4:Q4")   '???????
   
9.         n = n + 1
   
10.         If Rng.Value <> "" Then ss = Rng.Value
    
11.         C(ss & Rng.Offset(1, 0).Value) = n
    
12.     Next
    
13. 
    
14.     Rem ????????????
    
15.     Dim arr, i&, a(), x%, y%
    
16.     Dim key1$: key1 = Range("B2") & "*"  '??λ
    
17.     Dim key2$: key2 = Range("B3") & "*"  'С??λ
    
18. '    Dim key3$: key3 = Range("B4") & "*"  '????
    
19.     n = 0
    
20.     arr = Sheets("数据源").Range("A1").CurrentRegion
    
21.     For i = 2 To UBound(arr)
    
22.         If arr(i, 3) Like key1 And arr(i, 4) Like key2 Then  'And arr(i, 6) Like key3 Then  '??λ??С??λ??????
    
23.             x = C.Item(arr(i, 1) & arr(i, 11))   '????
    
24.             If Not d.Exists(arr(i, 9)) Then   '???μ?
    
25.                 n = n + 1: y = n
    
26.                 ReDim Preserve a(1 To 16, 1 To n)
    
27.                 d(arr(i, 9)) = n   '???μ?
    
28.             Else
    
29.                 y = d.Item(arr(i, 9))   '???μ?
    
30.             End If
    
31.             a(x, y) = a(x, y) + arr(i, 10)   '????
    
32.         End If
    
33.     Next
    
34. 
    
35.     Rem ?????????
    
36.     Sheet3.Select
    
37.     Application.ScreenUpdating = False
    
38.     Range("A6:N500").ClearContents
    
39.     Range("A6:N500").Borders.LineStyle = xlNone
    
40.     If n > 0 Then
    
41.         With Range("A6")
    
42.             .Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
43.             .Resize(d.Count + 1, 14).Font.Bold = False
    
44.             .Offset(d.Count, 0) = "???"
    
45.             .Offset(0, 13).Resize(d.Count, 1).FormulaR1C1 = "=SUM(RC2:RC13)"
    
46.             .Offset(0, 13).Resize(d.Count, 1).Font.Bold = True
    
47.             .Resize(d.Count + 1, 14).Borders.LineStyle = xlContinuous
    
48.         End With
    
49.         With Range("B6")
    
50.             .Resize(n, 12) = WorksheetFunction.Transpose(a)
    
51.             .Offset(n, 0).Resize(1, 13).FormulaR1C1 = "=SUM(R6C:R" & d.Count + 5 & "C)"
    
52.             .Offset(n, -1).Resize(1, 14).Font.Bold = True
    
53.         End With
    
54.     End If
    
55.     Application.ScreenUpdating = True
    
56. End Sub
    
57. 
    
58. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '???????????
    
59.     On Error Resume Next
    
60.     If Target.Address <> "$B$2:$K$2" And Target.Address <> "$B$3:$K$3" Then Exit Sub 'And Target.Address <> "$B$4:$I$4" Then Exit Sub
    
61.     Dim arr, d As Object, i&, x$
    
62.     Set d = CreateObject("scripting.dictionary")
    
63.     arr = Sheets("数据源").[a1].CurrentRegion
    
64.     For i = 2 To UBound(arr)
    
65.         x = arr(i, 3)
    
66.         If Not d.Exists(x) Then
    
67.             Set d(x) = CreateObject("Scripting.Dictionary")
    
68.             d(x)(arr(i, 4) & "") = arr(i, 5)
    
69.         ElseIf InStr("," & d(x)(arr(i, 4) & "") & ",", "," & arr(i, 5) & ",") = 0 Then
    
70.             d(x)(arr(i, 4) & "") = d(x)(arr(i, 4) & "") & "," & arr(i, 5)
    
71.         End If
    
72.     Next
    
73.     Sheet3.Unprotect
    
74.     With Target.Validation
    
75.         .Delete
    
76.         Select Case Target.Address
    
77.             Case "$B$2:$K$2"
    
78.                 .Add xlValidateList, , , Join(d.keys, ",")
    
79.                 [b3] = ""
    
80.             Case "$B$3:$K$3"
    
81.                 .Add xlValidateList, , , Join(d([B2].Value).keys, ",")
    
82. '                [b4] = ""
    
83. '            Case "$B$4:$I$4"
    
84. '                .Add xlValidateList, , , d([B2].Value)([b3].Value)
    
85.         End Select
    
86.     End With
    
87.     Sheet3.Protect UserInterfaceOnly:=True
    
88. End Sub
    
89. 
    

复制代码

lsc900707

①然如故 发表于 2019-3-14 22:27
lsc900707你好，原来只有5个表，见图

表名称栏也只显示5个，VB编辑器中每次打开在关闭都会成倍生成she ...

你用的是工作表事件，那代码就要贴在相应的工作表代码区。你贴好后再试试。

lsc900707

①然如故 发表于 2019-3-14 22:27
lsc900707你好，原来只有5个表，见图

表名称栏也只显示5个，VB编辑器中每次打开在关闭都会成倍生成she ...

回复在审核，你测试附件看看吧：

lsc900707

①然如故 发表于 2019-3-14 22:27
lsc900707你好，原来只有5个表，见图

表名称栏也只显示5个，VB编辑器中每次打开在关闭都会成倍生成she ...

代码贴错地方了。。。。。。

①然如故

lsc900707 发表于 2019-3-14 22:40
代码贴错地方了。。。。。。

lsc900707您好，不是代码放错地方，我也是看“小单位汇总”在哪个sheet就放哪里，请你运行代码然后保存再打开就会出现我描述的情况。

lsc900707

①然如故 发表于 2019-3-14 22:53
lsc900707您好，不是代码放错地方，我也是看“小单位汇总”在哪个sheet就放哪里，请你运行代码然后保存再 ...

那就证明代码有问题了，有时间我再看看吧。