万帖成专家之批量处理

LMY123

1   批量删除
2   批量移动
3   批量复制
4   批量打印
5   批量插入图片
6   所有工作薄执行同一个宏

约定的童话

广告啊？链接呢？试用版在哪？？？

LMY123

1. 'http://club.excelhome.net/thread-1302700-3-1.html
   
2. Sub 同夹_批量删除特定的工作表_A()
   
3.     Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
4.     路径 = ThisWorkbook.Path & "": 外薄 = Dir(路径 & "*.xls")
   
5.     Do While 外薄 <> ""
   
6.         If 外薄 <> ThisWorkbook.Name Then
   
7.             If 子程序(路径 & 外薄) Then
   
8.                 m = m + 1
   
9.                 With Workbooks.Open(路径 & 外薄)
   
10.                     For Each 工作表 In .Worksheets
    
11.                         If 工作表.Name <> "岁段名册总表" And 工作表.Name <> "在校生花名册" Then
    
12.                             n = n + 1
    
13.                             工作表.Delete
    
14.                         End If
    
15.                     Next 工作表
    
16.                     .Close True
    
17.                 End With
    
18.             End If
    
19.         End If
    
20.         外薄 = Dir
    
21.     Loop
    
22.     Application.DisplayAlerts = True: Application.ScreenUpdating = True
    
23.     If m > 0 Then
    
24.         MsgBox "已处理" & m & "个工作簿，删除了" & n & "个工作表", vbInformation
    
25.     Else
    
26.         MsgBox "没有发现需要删除工作表的工作簿。", vbInformation
    
27.     End If
    
28. End Sub
    
29. Function 子程序(ByVal MyPath$) As Boolean
    
30.     Dim 连接 As Object, 记录 As Object, s$
    
31.     Set 连接 = CreateObject("ADODB.Connection")
    
32.     连接.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 4.0;Data Source=" & MyPath
    
33.     Set 记录 = 连接.OpenSchema(20)
    
34.     Do Until 记录.EOF
    
35.         If 记录.Fields("TABLE_TYPE") = "TABLE" Then
    
36.             s = Replace(记录("TABLE_NAME").Value, "'", "")
    
37.             If s <> "岁段名册总表$" And s <> "在校生花名册$" Then
    
38.                 子程序 = True
    
39.                 Exit Do
    
40.             End If
    
41.         End If
    
42.         记录.MoveNext
    
43.     Loop
    
44.     记录.Close: Set 记录 = Nothing
    
45.     连接.Close: Set 连接 = Nothing
    
46. End Function
    
47. Sub 同夹_批量删除特定的工作表_E()
    
48.     路径 = ThisWorkbook.Path & "": 外薄 = Dir(路径 & "*.xls")
    
49.     Application.DisplayAlerts = False: Application.ScreenUpdating = False
    
50.     If MsgBox("是否确定要删除指定目录当中指定工作表" & Chr(13) & "请做好数据备份，一旦删除，无法恢复！", vbQuestion + vbYesNo, "重要提醒") = vbYes Then
    
51.         Do While 外薄 <> ""
    
52.             If 外薄 <> ThisWorkbook.Name Then
    
53.                 Set 打开的外薄 = Workbooks.Open(路径 & 外薄)
    
54.                 For Each 工作表 In 打开的外薄.Sheets
    
55.                     If 工作表.Name <> "岁段名册总表" And 工作表.Name <> "在校生花名册" Then 工作表.Delete
    
56.                 Next 工作表
    
57.                 打开的外薄.Save
    
58.                 打开的外薄.Close False
    
59.             End If
    
60.             外薄 = Dir
    
61.         Loop
    
62.     Else
    
63.         MsgBox "您已取消操作，数据未删除！"
    
64.     End If
    
65.     Application.DisplayAlerts = True: Application.ScreenUpdating = True
    
66. End Sub
    
67. Sub 多级_多夹_批量删除特定的工作表_ADO加子程序()
    
68.     Application.ScreenUpdating = False: Application.DisplayAlerts = False '//关闭系统提示
    
69.     FileArr = 子程序(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
    
70.     For I = 0 To UBound(FileArr)
    
71.         Set 打开的外薄 = Workbooks.Open(FileArr(I))
    
72.         For Each 工作表 In 打开的外薄.Worksheets
    
73.             If 工作表.Name <> "岁段名册总表" And 工作表.Name <> "在校生花名册" Then  '//
    
74.                 工作表.Delete
    
75.             End If
    
76.         Next 工作表
    
77.         打开的外薄.Close True
    
78.     Next I
    
79.     Application.ScreenUpdating = True: Application.DisplayAlerts = True '//恢复系统提示
    
80. End Sub
    
81. Public Function 子程序(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal SubFiles As Boolean = True, Optional ByVal Files As Boolean = False) As String()
    
82.     Dim 字典, 关键字, MyName, MyFileName
    
83.     Dim I As Integer
    
84.     Set 字典 = CreateObject("Scripting.Dictionary")
    
85.     Filename = Replace(Replace(Filename & "", "\", ""), "\", "")
    
86.     字典.Add (Filename), ""
    
87.     I = 0
    
88.     Do While I < 字典.Count
    
89.         关键字 = 字典.keys   '开始遍历字典
    
90.         If SubFiles = True Then  '//如果需要查找子文件夹
    
91.             MyName = Dir(关键字(I), vbDirectory)    '查找目录
    
92.             Do While MyName <> ""
    
93.                 If MyName <> "." And MyName <> ".." Then
    
94.                     If (GetAttr(关键字(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
95.                         字典.Add (关键字(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
96.                     End If
    
97.                 End If
    
98.                 MyName = Dir    '继续遍历寻找
    
99.             Loop
    
100.         End If
     
101.         I = I + 1
     
102.     Loop
     
103.     Dim arrx() As String
     
104.     I = 0
     
105.     If Files = True Then   '//是否只输出文件夹名
     
106.         For Each 关键字 In 字典.keys '以查找总表所在文件夹下所有excel文件为例
     
107.             ReDim Preserve arrx(I)
     
108.             If 关键字 <> Filename Then   '//自身文件夹除外
     
109.                 arrx(I) = 关键字
     
110.                 I = I + 1
     
111.             End If
     
112.         Next
     
113.         子程序 = arrx
     
114.     Else
     
115.         For Each 关键字 In 字典.keys '以查找总表所在文件夹下所有excel文件为例
     
116.             MyFileName = Dir(关键字 & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
     
117.             Do While MyFileName <> ""
     
118.                 If MyFileName <> Liwai Then '排除例外文件
     
119.                     ReDim Preserve arrx(I)
     
120.                     arrx(I) = 关键字 & MyFileName
     
121.                     I = I + 1
     
122.                 End If
     
123.                 MyFileName = Dir
     
124.             Loop
     
125.         Next
     
126.         子程序 = arrx
     
127.     End If
     
128. End Function

复制代码

DDBB2008

学习学习，好东西

流浪雨

好东东，收藏了，谢谢！！！