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

9890b

Sub 汇总()
    Dim strFileName As String, xlApp, xlBook, xlSheet
    Dim i As Integer, arr, temp(1 To 28, 1 To 10), j As Integer, k As Integer
    strFileName = Dir(ActiveWorkbook.Path & "\")
    i = 1
    Set xlApp = CreateObject("Excel.Application")
    Application.ScreenUpdating = False
    Do While strFileName <> ""
        If strFileName <> "汇总.xls" And InStr(strFileName, ".xls") > 0 Then
            Set xlBook = xlApp.Workbooks.Open(ActiveWorkbook.Path & "\" & strFileName)
            Set xlSheet = xlBook.Worksheets
            arr = xlSheet(1).Range("d6:m33")
            For j = 1 To 28
                For k = 1 To 10
                    temp(j, k) = temp(j, k) + arr(j, k)
                Next
            Next
        xlApp.DisplayAlerts = False
        xlBook.Close
        End If
        i = i + 1
        strFileName = Dir
    Loop
    xlApp.Quit
    Sheets(1).Range("d6:m33") = temp
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-12-13 13:50

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个表就成了。

跳转到最佳答案楼层

hwc2ycy

xlSheet(1),这统计了一张表的。
改用循环吧。

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
   
4.     strFileName = Dir(ActiveWorkbook.Path & "")
   
5.     i = 1
   
6.     Set xlApp = CreateObject("Excel.Application")
   
7.     Application.ScreenUpdating = False
   
8.     Do While strFileName <> ""
   
9.         If strFileName <> "汇总.xls" And InStr(strFileName, ".xls") > 0 Then
   
10.             Set xlBook = xlApp.Workbooks.Open(ActiveWorkbook.Path & "" & strFileName)
    
11.             For Each xlSheet In xlBook.Worksheets
    
12.                 arr = xlSheet.Range("d6:m33")
    
13.                 For j = 1 To 28
    
14.                     For k = 1 To 10
    
15.                         temp(j, k) = temp(j, k) + arr(j, k)
    
16.                     Next
    
17.                 Next
    
18.             Next
    
19.             xlApp.DisplayAlerts = False
    
20.             xlBook.Close
    
21.         End If
    
22.         i = i + 1
    
23.         strFileName = Dir
    
24.     Loop
    
25.     xlApp.Quit
    
26.     Sheets(1).Range("d6:m33") = temp
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

9890b

hwc2ycy 发表于 2013-12-13 10:21

老师，还是不行呢

hwc2ycy

代码是你的改的。
要么你发附件我来测。

hwc2ycy

是哪不行，你要么贴效果图。
是代码运行不了，还是执行结果不对，要讲清楚点。

9890b

这是附件，我要求汇总各个文件下的三个工作表到一个工作簿

9890b

执行结果不对，只能汇总一个工作表，而不是三个工作表。

hwc2ycy

9890b 发表于 2013-12-13 10:38
执行结果不对，只能汇总一个工作表，而不是三个工作表。

你尽里在别人的楼层里点回复。
strFileName <> "汇总.xls"
这里不对

1. Sub 汇总()
   
2. 
   
3.     Dim strFileName As String, xlApp, xlBook, xlSheet
   
4. 
   
5.     Dim i As Integer, arr, temp(1 To 28, 1 To 10), j As Integer, k As Integer
   
6. 
   
7.     strFileName = Dir(ActiveWorkbook.Path & "")
   
8. 
   
9.     i = 1
   
10. 
    
11.     Set xlApp = CreateObject("Excel.Application")
    
12. 
    
13.     Application.ScreenUpdating = False
    
14. 
    
15.     Do While strFileName <> ""
    
16. 
    
17.         If strFileName <> ThisWorkbook.Name And InStr(strFileName, ".xls") > 0 Then
    
18. 
    
19.             Set xlBook = xlApp.Workbooks.Open(ActiveWorkbook.Path & "" & strFileName)
    
20. 
    
21.             For Each xlSheet In xlBook.Worksheets
    
22. 
    
23.                 arr = xlSheet.Range("d6:m33")
    
24. 
    
25.                 For j = 1 To 28
    
26. 
    
27.                     For k = 1 To 10
    
28. 
    
29.                         temp(j, k) = temp(j, k) + arr(j, k)
    
30. 
    
31.                     Next
    
32. 
    
33.                 Next
    
34. 
    
35.             Next
    
36. 
    
37.             xlApp.DisplayAlerts = False
    
38. 
    
39.             xlBook.Close
    
40. 
    
41.         End If
    
42. 
    
43.         i = i + 1
    
44. 
    
45.         strFileName = Dir
    
46. 
    
47.     Loop
    
48. 
    
49.     xlApp.Quit
    
50. 
    
51.     Sheets(1).Range("d6:m33") = temp
    
52. 
    
53.     Application.ScreenUpdating = True
    
54. 
    
55. End Sub

复制代码

hwc2ycy

另外，你不是每个工作簿的所有工作表汇总成一个工作表？
我看你的BOOKS1里有三个工作表。