叠加汇总数据

哈哈哈。

汇总表.zip (660.55 KB, 下载次数: 10)

2019-9-6 11:13 上传

点击文件名下载附件

如附件，新增表格与原有统计过的表格放置在同一文件夹内提取汇总，数据过多容易造成提取过慢，如何实现汇总时保留原先已有的数据只对新增的表格进行数据提取。还请大神指点！

半百

在原代码上改的。
Public Sub hebing()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Dim wb As Workbook  '定义工作簿变量
   Dim sht As Worksheet  '定义工作表变量
   mypath = ThisWorkbook.Path & "\"  '获取当前程序运行的目录
   TMPNAME = Dir(mypath & "*.xlsx")  '获取工作簿名称
   Set D = CreateObject("scripting.dictionary")
   
   R = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row  '获取当前工作表的最大行号
   ARR = Sheet1.Range("B2:B" & R)
   For I = 1 To UBound(ARR)
   D(ARR(I, 1)) = ""
   Next
   
   Do While TMPNAME <> ""  '循环判断  工作簿名称不为空，就进行提取数据
   If Not D.EXISTS(Left(TMPNAME, 10)) Then
     If TMPNAME <> ThisWorkbook.Name Then   '判断工作簿名称不等于当前程序工作簿名称
     
        Set wb = Workbooks.Open(mypath & TMPNAME, 0, 1)  '打开工作簿，赋值给变量  wb
        
        Set sht = wb.Sheets(1)  ' 赋值打开工作簿的第一个工作表给变量 sht
        
        R = sht.Cells(Rows.Count, "b").End(xlUp).Row  '获取打开的工作簿，最大行号
        
        sjrr = sht.Range("a1:e" & R)  '获取已打开工作簿的数据到  数组  sjrr
        
        jifang = Mid(TMPNAME, 1, 10) '打开工作表的 a1 单元格值 机房位置 jifang
        
        rq = Mid(jifang, 1, 4) & "/" & Mid(jifang, 5, 2) & "/" & Mid(jifang, 7, 2)  '根据a1 单元格的值 生成日期
        
        
        For I = 1 To UBound(sjrr)  '表中的数据
        
            If sjrr(I, 1) <> "" Then  '判断a列的 值不为空，就把a列的值 也就是机房编号给变量 jfbh
                   jfbh = sjrr(I, 1)
            End If
               
            If sjrr(I, 2) <> "" Then  '判断第二列值不为空  就开始累加输出信息到工作表
            
                mr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1  '获取汇总工作表的最后行号  给变量mr
                With Sheet1
                     .Cells(mr, "a") = rq            '输出日期
                     .Cells(mr, "b") = jifang        '机房巡检次数
                     .Cells(mr, "c") = jfbh          '机房编号
                     .Cells(mr, "d") = sjrr(I, 2)    '机柜位置
                     .Cells(mr, "e") = getwd(sjrr(I, 3)) '左边温度  getwd 是一个自定义函数 传入原始数据，自动清除温度符号和获取最大值
                     .Cells(mr, "f") = getwd(sjrr(I, 4)) '中间温度
                     .Cells(mr, "g") = getwd(sjrr(I, 5)) '右边温度
                     If .Cells(mr, "e") <> 0 Or .Cells(mr, "f") <> 0 Or .Cells(mr, "g") <> 0 Then
                     .Cells(mr, "H") = Application.Average(.Cells(mr, "e"), .Cells(mr, "f"), .Cells(mr, "g"))
                     End If
                End With
           End If
           VBA.DoEvents  '释放系统控制权，防止程序假死
        Next
        wb.Close  '关闭已打开的工作簿
     End If
     End If
     TMPNAME = Dir()  '获取下一个文件的工作簿名称
   Loop
   
     
   MsgBox "ok"  '处理完成，消息提示框
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   
End Sub