[已解决]以下代码只能统计一个工作表，我要统计所有表，怎么修改

hwc2ycy

9890b 发表于 2013-12-13 12:31
我运行了你的代码，第一个工作表变成了9个工作簿相加，第二个表变成了6个工作簿相加，第三个工作表变成了 ...

早干嘛去了，不说明白，下次提问要注意下。

9890b

hwc2ycy 发表于 2013-12-13 12:27
早要说明白嘛，绕一大圈。

不好意思，辛苦了

我运行了你的代码，第一个工作表变成了9个工作簿相加，第二个表变成了6个工作簿相加，第三个工作表变成了9个工作簿相相，我的要求是有几个工作簿就是几个工作簿相加。

hwc2ycy

1. Sub 汇总()
   
2.     Dim strFileName As String, xlApp, xlBook, xlSheet
   
3.     Dim i As Integer, arr, temp(1 To 28, 1 To 10), j As Integer, k As Integer, arrTemp
   
4.     Dim arr2(1 To 3) As Variant
   
5.     For i = 1 To UBound(arr2)
   
6.         arr2(i) = temp
   
7.     Next
   
8. 
   
9.     strFileName = Dir(ActiveWorkbook.Path & "")
   
10.     Set xlApp = CreateObject("Excel.Application")
    
11.     Application.ScreenUpdating = False
    
12.     Do While strFileName <> ""
    
13.         If strFileName <> ThisWorkbook.Name And InStr(strFileName, ".xls") > 0 Then
    
14.             Set xlBook = xlApp.Workbooks.Open(ActiveWorkbook.Path & "" & strFileName)
    
15.             Set xlSheet = xlBook.Worksheets
    
16.             For i = 1 To xlSheet.Count
    
17.                 arr = xlSheet(i).Range("d6:m33")
    
18.                 arrTemp = arr2(i)
    
19.                 For j = 1 To 28
    
20.                     For k = 1 To 10
    
21.                         arrTemp(j, k) = arrTemp(j, k) + arr(j, k)
    
22.                     Next
    
23.                 Next
    
24.                 arr2(i) = arrTemp
    
25.             Next
    
26.             xlApp.DisplayAlerts = False
    
27.             xlBook.Close
    
28.         End If
    
29.         strFileName = Dir
    
30.     Loop
    
31.     xlApp.Quit
    
32.     For i = 1 To UBound(arr2)
    
33.         Sheets(i).Range("d6:m33") = arr2(i)
    
34.     Next
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

9890b

hwc2ycy 发表于 2013-12-13 12:42

谢谢您喔，这是我所要的结果。
追问：

如果，我在book1里（也就是汇总工作簿里）每个工作表中都是空白表，也要达到你代码要求，怎么更改代码

9890b

9890b 发表于 2013-12-13 12:52
谢谢您喔，这是我所要的结果。
追问：

[tr][/tr]

编制单位:
科目编号		预算科目名称
			目	节
			教育经费支出合计
1		财政统发工资
	1	岗位工资
	2	薪级工资
	3	工标10%部分
	4	级别工资
	5	职务工资
	6	艰苦边远地区津贴
	7	女职工卫生费
	8	教龄津贴
	9	特级教师津贴
	10	补发工资
2		经费补助

把这些项目（也就是文字的项目）自动取上去

9890b

hwc2ycy 发表于 2013-12-13 12:42

[tr][/tr]

编制单位:
科目编号		预算科目名称
			目	节
			教育经费支出合计
1		财政统发工资
	1	岗位工资
	2	薪级工资
	3	工标10%部分
	4	级别工资
	5	职务工资
	6	艰苦边远地区津贴
	7	女职工卫生费
	8	教龄津贴
	9	特级教师津贴
	10	补发工资
2		经费补助

把文字的项目取到汇总表里，

hwc2ycy

9890b 发表于 2013-12-13 12:57
[/td][/tr]

第一次的时候，直接复制工作表过来吧，数据清除就成了。

hwc2ycy

1. Sub 汇总()
   
2.     Dim strFileName As String
   
3.     Dim temp(1 To 28, 1 To 10), arr, arrTemp
   
4.     Dim i As Integer, j As Integer, k As Integer
   
5.     Dim arr2(1 To 3) As Variant
   
6.     Dim blCopy As Boolean
   
7.    
   
8.     For i = 1 To UBound(arr2)
   
9.         arr2(i) = temp
   
10.     Next
    
11. 
    
12.     strFileName = Dir(ActiveWorkbook.Path & "\*.xls")
    
13.     With Application
    
14.         .ScreenUpdating = False
    
15.         .DisplayAlerts = False
    
16.         .EnableEvents = False
    
17.         .Calculation = xlCalculationManual
    
18.     End With
    
19. 
    
20.     Do While strFileName <> ""
    
21.         If strFileName <> ThisWorkbook.Name Then
    
22.             With GetObject(ActiveWorkbook.Path & "" & strFileName)
    
23.                 For i = 1 To .Worksheets.Count
    
24.                     If Not blCopy Then
    
25.                         .Worksheets(i).Copy before:=Worksheets(i)
    
26.                     End If
    
27. 
    
28.                     arr = .Worksheets(i).Range("d6:m33")
    
29.                     arrTemp = arr2(i)
    
30.                     For j = 1 To 28
    
31.                         For k = 1 To 10
    
32.                             arrTemp(j, k) = arrTemp(j, k) + arr(j, k)
    
33.                         Next
    
34.                     Next
    
35.                     arr2(i) = arrTemp
    
36.                 Next
    
37.                 Windows(.Name).Visible = True
    
38.                 blCopy = True
    
39.                 .Close False
    
40.             End With
    
41.         End If
    
42.         strFileName = Dir
    
43.     Loop
    
44. 
    
45.     For i = Worksheets.Count To UBound(arr2) + 1 Step -1
    
46.         Worksheets(i).Delete
    
47.     Next
    
48.     For i = 1 To UBound(arr2)
    
49.         With Worksheets(i)
    
50.             .Range("d6:m33") = arr2(i)
    
51.             .Name = "sheet" & i
    
52.         End With
    
53.     Next
    
54.     With Application
    
55.         .ScreenUpdating = True
    
56.         .DisplayAlerts = True
    
57.         .EnableEvents = True
    
58.         .Calculation = xlCalculationAutomatic
    
59.     End With
    
60.     MsgBox "汇总完成", vbInformation
    
61. End Sub
    

复制代码

只要格式相同，都是3个表就成了。

9890b

hwc2ycy 发表于 2013-12-13 13:50
只要格式相同，都是3个表就成了。

对头，多谢了，以后有问题向你请教

hwc2ycy

9890b 发表于 2013-12-13 14:43
对头，多谢了，以后有问题向你请教

问题解决了就记得设置最佳答案。