多工作簿汇总到一个表

plaodj

多工作簿汇总到一个表

1. Sub CltSheets()
   
2.    Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K&
   
3.   Dim Sht As Worksheet, Sh As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   On Error Resume Next
   
7.   With Application.FileDialog(msoFileDialogFolderPicker)
   
8.     .AllowMultiSelect = False
   
9.     If .Show Then P = .SelectedItems(1) Else: Exit Sub
   
10.   End With
    
11.   If Right(P, 1) <> "" Then P = P & ""
    
12.   Keystr1 = InputBox("请输入工作簿名称所包含的关键词" & vbCr & "关键词可以为空，如为空，则默认选择全部工作簿")
    
13.   If StrPtr(Keystr1) = 0 Then Exit Sub '如果用户点击了取消或关闭按钮，则退出程序
    
14.   Keystr2 = InputBox("请输入工作表名称所包含的关键词" & vbCr & "关键词可以为空，如为空，则默认选择符合条件工作簿的全部工作表")
    
15.   If StrPtr(Keystr2) = 0 Then Exit Sub
    
16.   Set Sh = ActiveSheet '当前工作表，赋值变量,代码运行完毕后，回到此表
    
17.   Bookn = Dir(P & "*.xls*")
    
18.   Do While Bookn <> ""
    
19.     If Bookn = ThisWorkbook.Name Then
    
20.       MsgBox "注意：指定文件夹中存在和当前表格重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制"
    
21.      '当出现重名工作簿时，提醒用户
    
22.     Else
    
23.       If InStr(1, Bookn, Keystr1, vbTextCompare) Then
    
24.      '工作簿名称是否包含关键词，关键词不区分大小写
    
25.         With GetObject(P & Bookn)
    
26.           For Each Sht In .Worksheets
    
27.             If InStr(1, Sht.Name, Keystr2, vbTextCompare) Then
    
28.            '工作表名称是否包含关键词，关键词不区分大小写
    
29.               If Application.CountIf(Sht.UsedRange, "<>") Then
    
30.              '如果表格存在数据区域
    
31.                 Shtname = Split(Bookn, ".xls")(0) & "-" & Sht.Name
    
32.                '复制来的工作表以"工作簿-工作表"形式起名
    
33.                 ThisWorkbook.Sheets(Shtname).Delete
    
34.                '如果已存在相关表名，则删除
    
35.                 Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
    
36.                 K = K + 1
    
37.                '复制Sht到代码所在工作簿所有工作表的后面，并累计个数
    
38.                 ActiveSheet.Name = Shtname
    
39.                '工作表命名
    
40.               End If
    
41.             End If
    
42.           Next
    
43.           .Close False '关闭工作簿
    
44.         End With
    
45.       End If
    
46.     End If
    
47.     Bookn = Dir '下一个符合条件的文件
    
48.   Loop
    
49.   Sh.Select '回到初始工作表
    
50.   MsgBox "工作表收集完毕，共收集：" & K & "个"
    
51.   Application.ScreenUpdating = True
    
52.   Application.DisplayAlerts = True
    
53. End Sub

复制代码