[已解决]请高手帮忙制作VBA,将多个报表汇总到同一个工作表上

清秋淡水

请高手帮忙制作VBA,将多个报表汇总到同一个工作表上，
1.将《日报表》的每张工作表内容汇总到《日报表汇总》中，具体要求在附件《日报表汇总》中
2.每天有一份单独的《机台报表》，如《机台报表2015.12.01，机台报表2015.12.02》，要求将每天的《机台报表》内容汇总到《机台报表汇总》中，具体要求在附件《机台报表汇总》中
非常感谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-28 11:36

先来日报表的。

1. Sub 打开指定文件()          '用文件选择界面打开文件
   
2.     Dim Fil, wb As Workbook, sh As Worksheet, Rng As Range
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     With ThisWorkbook.Sheets(1)
   
7.         Set wb = Workbooks.Open(Fil)        '打开文件
   
8.         For Each sh In wb.Worksheets
   
9.             Set Rng = sh.UsedRange.Find("备注")
   
10.             If Not Rng Is Nothing Then
    
11.                 If Rng.Row > 4 Then
    
12.                     r = .[a65536].End(3).Row + 1
    
13.                     sh.Range("a4:bj" & Rng.Row - 1).Copy .Cells(r, 1)
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.         wb.Close False
    
18.     End With
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

先来日报表的。

1. Sub 打开指定文件()          '用文件选择界面打开文件
   
2.     Dim Fil, wb As Workbook, sh As Worksheet, Rng As Range
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     With ThisWorkbook.Sheets(1)
   
7.         Set wb = Workbooks.Open(Fil)        '打开文件
   
8.         For Each sh In wb.Worksheets
   
9.             Set Rng = sh.UsedRange.Find("备注")
   
10.             If Not Rng Is Nothing Then
    
11.                 If Rng.Row > 4 Then
    
12.                     r = .[a65536].End(3).Row + 1
    
13.                     sh.Range("a4:bj" & Rng.Row - 1).Copy .Cells(r, 1)
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.         wb.Close False
    
18.     End With
    
19. End Sub
    

复制代码

grf1973

另一个机台报表情况基本一样的。代码几乎可以套用。

grf1973

1. Sub 导入()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim wb As Workbook, sh As Worksheet
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
7.     With ThisWorkbook.Sheets(1)
   
8.         For Each fff In ff.subfolders
   
9.            For Each f In fff.Files
   
10.              Set wb = Workbooks.Open(f)
    
11.              r = .[a65536].End(3).Row + 1
    
12.              wb.Sheets(1).[a1].CurrentRegion.Offset(2).Copy .Cells(r, 1)
    
13.              r = .[a65536].End(3).Row + 1
    
14.              wb.Sheets(2).[a1].CurrentRegion.Offset(2).Copy .Cells(r, 1)
    
15.              ActiveWorkbook.Close False
    
16.            Next
    
17.         Next
    
18.     End With
    
19.     Application.ScreenUpdating = True
    
20.     Application.DisplayAlerts = True
    
21. End Sub

复制代码

清秋淡水

grf1973 发表于 2015-12-28 13:28

大侠，太崇拜你了，又一次帮我解决了难题，多谢多谢！

清秋淡水

grf1973 发表于 2015-12-28 13:28

1.大侠，再帮我看一下，机台报表我下载后，只有那上传的那两个EXCEL表中的内容自动复制到汇总表中，我放了其它日期的EXCEL表在同一路径中，点击按钮后，没有汇总，不知是怎么回事，谢谢。
2.我有另一份日报表的格式与那份做的格式差不多，只是少了几列，无法套用做好的那份，也请帮我处理一下，非常感谢。如附件，

grf1973

1、机台报表汇总重做了一下，考虑所有子文件夹及本文件夹下文件。
2、日报表汇总不知何故用复制出错，直接用数组读取内容。