求助多文件汇总到一个工作簿后无法生成汇总数据

dagal

A表汇总.rar (847.45 KB, 下载次数: 23)

2018-7-9 18:28 上传

点击文件名下载附件

不知代码错在哪了，求助大神们帮我看看，而且部分列是有公式的，最好汇总后公式能保留，毕竟有公式的部分如果相加的话肯定值是不对的。。。

鄂龙蒙

1. Sub gj23w98()
   
2.     Dim oHz As Boolean
   
3.     Dim Arr(), Brr()
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> ActiveSheet.Name Then sht.Delete
   
8.     Next
   
9. '    Application.DisplayAlerts = True
   
10. '    On Error Resume Next
    
11.     Set wk = ThisWorkbook
    
12.     p = ThisWorkbook.Path & ""
    
13.     f = Dir(p & "*.xls")
    
14.     Do While f <> ""
    
15.         If f <> ThisWorkbook.Name Then
    
16.             Set ws = Workbooks.Open(p & f)
    
17.             For Each sht In ws.Worksheets
    
18.                 If InStr(sht.Name, "本月数") Then
    
19.                     If oHz Then
    
20.                         Brr = sht.Range("c7:x43").Value
    
21.                         For i = 1 To 37
    
22.                            For j = 1 To 22
    
23. '                                If Brr(i, j) <> 0 Then Arr(i, j) = Arr(i, j) + Brr(i, j)
    
24.                                 If VBA.IsNumeric(Brr(i, j)) And VBA.IsNumeric(Arr(i, j)) Then Arr(i, j) = Arr(i, j) + Brr(i, j)
    
25.                            Next
    
26.                         Next
    
27.                     Else
    
28.                         sht.Copy after:=wk.Sheets(wk.Sheets.Count)
    
29.                         Arr = sht.Range("c7:x43").Value
    
30.                         oHz = True
    
31.                     End If
    
32.                     sht.Copy after:=wk.Sheets(wk.Sheets.Count - 1)
    
33.                     ActiveSheet.Name = Replace(Split(Split(f, ".")(0), "-")(1), "A表", "")
    
34.                 End If
    
35.             Next
    
36.             ws.Close False
    
37.         End If
    
38.         f = Dir
    
39.     Loop
    
40. '    Sheets("汇总").Range("c7:x42").Value = Arr
    
41. '    Sheets("汇总").Range("a3").Value = "编制单位：A表汇总"
    
42.     MsgBox "汇总完成!"
    
43.     Sheets("取数").Activate
    
44.     Application.ScreenUpdating = True
    
45. End Sub

复制代码

liulang0808

Sheets("汇总").Range("c7:x42").Value = Arr
这种歌赋值会导致公式被值覆盖掉

dagal

liulang0808 发表于 2018-7-9 19:01
Sheets("汇总").Range("c7:x42").Value = Arr
这种歌赋值会导致公式被值覆盖掉

好像是，不知有何办法可以公式部分保留呢

liulang0808

dagal 发表于 2018-7-9 19:16
好像是，不知有何办法可以公式部分保留呢

数组部分修改成单元格格式累加，增加对单元格内有无公式的判断

dagal

鄂龙蒙 发表于 2018-7-9 19:01

不行呀，你这样点完啥也没有出来呢。。。

dagal

liulang0808 发表于 2018-7-9 19:19
数组部分修改成单元格格式累加，增加对单元格内有无公式的判断

楼上的代码测试完啥也没有。。。奇怪

dagal

liulang0808 发表于 2018-7-9 19:19
数组部分修改成单元格格式累加，增加对单元格内有无公式的判断

本来是想这样，可是有22列，要一列列的分开写吧。。。

liulang0808

dagal 发表于 2018-7-9 19:26
本来是想这样，可是有22列，要一列列的分开写吧。。。

不是有for循环遍历吗

dagal

搞不定，有人帮忙一下么。。。