多表时间段汇总问题

sunche

本汇总表统计数据有点麻烦，我调了好久没有成功。请各位老师帮忙！要求已写在附件的汇总表，谢谢！

鄂龙蒙

楼主【汇总表】中的【期初余额】【期未余额】概念不对呀！

abc123281

看了一下你的附件   想要实现并不难    但我们很难明白你的表间关系   而且汇总表的表头和分表的表头也对不上

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim mypath$, myname$
   
5.   Dim ws As Worksheet
   
6.   Dim d As Object
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   With Worksheets("报表")
    
11.     rq1 = .Range("c2")
    
12.     rq2 = .Range("e2")
    
13.   End With
    
14.   mypath = ThisWorkbook.Path & ""
    
15.   myname = Dir(mypath & "*.xls")
    
16.   Do While myname <> ""
    
17.     If myname <> ThisWorkbook.Name Then
    
18.       Set wb = GetObject(mypath & myname)
    
19.       With wb
    
20.         xm = Split(myname, ".")(0)
    
21.         ReDim brr(1 To 5)
    
22.         brr(1) = xm
    
23.         With .Worksheets("sheet1")
    
24.           r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
25.           arr = .Range("c5:k" & r)
    
26.           For i = 1 To UBound(arr)
    
27.             If IsEmpty(brr(2)) Then
    
28.               If arr(i, 1) >= rq1 Then
    
29.                 If i > 1 Then
    
30.                   brr(2) = arr(i - 1, 9)
    
31.                 End If
    
32.               End If
    
33.             End If
    
34.             If arr(i, 1) >= rq1 And arr(i, 1) <= rq2 Then
    
35.               brr(3) = brr(3) + arr(i, 7)
    
36.               brr(4) = brr(4) + arr(i, 8)
    
37.             End If
    
38.           Next
    
39.         End With
    
40.         d(xm) = brr
    
41.         .Close False
    
42.       End With
    
43.     End If
    
44.     myname = Dir
    
45.   Loop
    
46.   arr = Application.Transpose(Application.Transpose(d.items))
    
47.   For i = 1 To UBound(arr)
    
48.     arr(i, 5) = arr(i, 2) + arr(i, 3) - arr(i, 4)
    
49.   Next
    
50.   With Worksheets("报表")
    
51.     .Range("a5").Resize(UBound(arr), UBound(arr, 2)) = arr
    
52.   End With
    
53.   Application.ScreenUpdating = True
    
54.   MsgBox "数据统计完毕！"
    
55. End Sub
    

复制代码

chxw68

详见附件。

sunche

谢谢两位老师，已达到我的目的！

eric0793

chxw68 发表于 2018-4-27 09:58
详见附件。

好几天不见褚老师了，又有新学习案例了：）