如何将同个文件夹内的多个sheet2页复制可见内容并汇总到汇总表

exyantou

ruhong18 发表于 2019-12-13 19:50
你好，这个是我疏忽了，没有表达清楚，不好意思，图标大概就是sheet2页面上的按钮图标，假设有图标图形的 ...

1. Option Explicit
   
2. Sub 汇总表格()
   
3.   Dim filename$, sheet_name$, arr_filename(1 To 10 ^ 3) As String
   
4.   Dim filecount%, i%, k%
   
5.   Dim sh As Worksheet, wb As Object, d As Object, sheetcount_before%
   
6.   Dim shapecount%, myshape As Object
   
7.     sheetcount_before = ThisWorkbook.Sheets.Count
   
8.     filename = Dir(ThisWorkbook.Path & "\*.xl*")
   
9.       Do While filename <> ""
   
10.         If filename <> ThisWorkbook.Name Then
    
11.           filecount = filecount + 1
    
12.           arr_filename(filecount) = filename
    
13.           filename = Dir
    
14.         Else
    
15.           filename = ""
    
16.         End If
    
17.       Loop
    
18.     Set d = CreateObject("scripting.dictionary")
    
19.     For i = 1 To ThisWorkbook.Sheets.Count
    
20.       d(Sheets(i).Name) = ""
    
21.     Next i
    
22.     Application.ScreenUpdating = False
    
23.     Application.DisplayAlerts = False
    
24.     For k = 1 To filecount
    
25.       sheet_name = Format(Mid(arr_filename(k), InStr(arr_filename(k), ".") - 2, 2), "00")
    
26.       If Not d.exists(sheet_name) Then
    
27.         Set wb = Workbooks.Open(ThisWorkbook.Path & "" & arr_filename(k))
    
28.         wb.Sheets("sheet2").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
29.         ActiveSheet.Name = sheet_name
    
30.           For Each myshape In ActiveSheet.Shapes
    
31.             myshape.Delete
    
32.           Next myshape
    
33.           If ActiveSheet.AutoFilterMode = True Then Rows(2).AutoFilter
    
34.           ActiveSheet.Cells.Copy
    
35.           ActiveSheet.[a1].PasteSpecial xlPasteValues
    
36.           'ActiveSheet.Cells.Interior.ColorIndex = xlNone
    
37.           'ActiveSheet.Cells.Font.ColorIndex = vbBlack
    
38.         wb.Close False
    
39.       End If
    
40.     Next
    
41.     Application.ScreenUpdating = True
    
42.     Application.DisplayAlerts = True
    
43.   MsgBox "执行完成，本次共更新" & ThisWorkbook.Sheets.Count - sheetcount_before & "个文件", vbInformation
    
44. End Sub
    
45. 
    

复制代码

试试这个

exyantou

exyantou 发表于 2019-12-13 22:27

补充：若果需要去掉表格单元格颜色和字体颜色，请删掉第36行、37行前面的逗号。

ruhong18

exyantou 发表于 2019-12-13 22:28
补充：若果需要去掉表格单元格颜色和字体颜色，请删掉第36行、37行前面的逗号。

感谢，学习~！