按模版表样控制不重复建新表

xmtdabc

问题：是按商品名称命名建立新表，不重复建立，没有新增商品是不建表，现在是没有新增商品时，建一个模板表。如何能控制住？

代码如下（本论坛找查的）：

Sub 添加工作表()
    Dim arr, i&, Myr&, dic_sheet As Object, sheet As Worksheet   '定义变量
    Application.ScreenUpdating = False                                      '关闭屏幕刷新
    Set dic_sheet = CreateObject("Scripting.Dictionary")              '定义dic_sheet 为字典对象
    With Sheet1
        Myr = .Cells(Rows.Count, 3).End(3).Row                    '找到A列最后有数据的行
        arr = .Cells(11, 1).Resize(Myr, 11).Value                       '定义数组arr
    End With
    For Each sheet In Worksheets                                             '遍历工作表
        dic_sheet.Add sheet.Name, ""                                          '把工作表名存入字典
    Next
    For i = LBound(arr) To UBound(arr)                                      '在数组arr中循环
        If Not dic_sheet.exists(arr(i, 3)) Then                           '如果字典中不存在这个工作表名
            Sheet8.Copy After:=Sheets(Worksheets.Count)       '就在已有工作表的后面添加一个新工作表sheet8是模板
            Sheets(Worksheets.Count).Name = arr(i, 3)               '把这个新工作表重新命名
            dic_sheet(arr(i, 1)) = ""
        End If
    Next
    Set dic_sheet = Nothing                                                     '在内存中清除字典
    Sheet1.Activate                                                                 '激活SHEET1工作表
    Application.ScreenUpdating = True                                      '开启屏幕刷新
End Sub



简单进销存.rar (280.51 KB, 下载次数: 10)

2013-1-10 10:43 上传

点击文件名下载附件

xmtdabc

请高人出手求教

蓝桥玄霜

1. Sub 添加工作表()
   
2.     Dim Arr, i&, Myr&, dic_sheet As Object, sheet As Worksheet   '定义变量
   
3.     Dim Sht As Worksheet
   
4.     Application.ScreenUpdating = False                                      '关闭屏幕刷新
   
5.     Sheet1.Activate                                                                 '激活SHEET1工作表
   
6.     Set dic_sheet = CreateObject("Scripting.Dictionary")              '定义dic_sheet 为字典对象
   
7.     With Sheet1
   
8.         Myr = .Cells(Rows.Count, 3).End(3).Row                    '找到A列最后有数据的行
   
9.         Arr = .Cells(11, 1).Resize(Myr, 11).Value                       '定义数组arr
   
10.     End With
    
11.     For Each sheet In Worksheets                                             '遍历工作表
    
12.         dic_sheet.Add sheet.Name, ""                                          '把工作表名存入字典
    
13.     Next
    
14.     For i = LBound(Arr) To UBound(Arr)                                      '在数组arr中循环
    
15.         If Not dic_sheet.exists(Arr(i, 3)) And Arr(i, 3) <> "" Then                        '如果字典中不存在这个工作表名
    
16.             Sheet8.Copy After:=Sheets(Worksheets.Count)       '就在已有工作表的后面添加一个新工作表sheet8是模板
    
17.             Set Sht = ActiveSheet
    
18.             Sht.Name = Arr(i, 3)               '把这个新工作表重新命名
    
19.             'Sheets(arr(i, 3)).[A2] = arr(i, 3)
    
20.             dic_sheet(Arr(i, 3)) = ""
    
21.         End If
    
22.     Next
    
23.     Set dic_sheet = Nothing                                                     '在内存中清除字典
    
24.     MsgBox "OK"
    
25.     Application.ScreenUpdating = True                                      '开启屏幕刷新
    
26. End Sub
    

复制代码

蓝桥玄霜

请见附件。

xmtdabc

蓝桥玄霜 发表于 2013-1-10 14:39
请见附件。

非常感谢，经常看到高手在各个贴子中的经典回复。

zyy19880218

其实3楼代码有个问题：如果工作表名字是纯数字，那么代码只能成功运行一次。