[已解决]跪求;修改完善代码。达到我的目的就可以！谢谢！

feiaoli

求助：1、在D2单元格选择相应日期后表格第6行（累计发生数）只显示当年度累计发生数！同时第4行全年预算数显示相应年度数据
       2、在D2单元格增加一个所有年度统计有效性(比如2015-2017），选择后表格第6行（累计发生数）显示所有年度累计发生数！同时第4行全年预算数显示所有年度数据，以及清空第5行本月发生数
       第一个数据列表和第二个数据列表都是动态日期的。
请修改代码！
       以上第一条完成就万分感激！第2条完成就更完美了！谢谢

最佳答案

月排行榜 / 总排行榜

grf1973

2016-1-12 16:42

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim xrng As Range
   
3.     If Target.Address <> [d2].Address Then Exit Sub
   
4.     Dim brr(1 To 2, 1 To 6)
   
5.     r1 = Range("a:a").Find("汇总", , , , , xlNext).Row     '上一张表的汇总行
   
6.     r2 = Range("a:a").Find("汇总", , , , , xlPrevious).Row        '下一张表的汇总行
   
7.     rq = Target    '给定日期
   
8.     If rq = "全部" Then
   
9.         [b4].Resize(1, 6).Value = Cells(r2, 2).Resize(1, 6).Value
   
10.         [b5].Resize(1, 6).Value = ""
    
11.         [b6].Resize(1, 6).Value = Cells(r1, 2).Resize(1, 6).Value
    
12.     Else
    
13.         arr = Range("a8:g" & r1 - 1)
    
14.         nd = Year(rq)    '年度
    
15.         For i = 1 To UBound(arr)
    
16.             xrq = arr(i, 1) '日期
    
17.             If xrq <= rq And nd = Year(xrq) Then    '同年累计
    
18.                 For j = 1 To 6
    
19.                     brr(2, j) = brr(2, j) + arr(i, j + 1)
    
20.                     If rq = xrq Then brr(1, j) = arr(i, j + 1)    '本月数
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         Range("b5:g6") = brr
    
25.         Set xrng = Range("a:a").Find(nd, , , lookat:=xlWhole)    '全年预算
    
26.         If Not xrng Is Nothing Then [b4].Resize(1, 6).Value = Cells(xrng.Row, 2).Resize(1, 6).Value
    
27.     End If
    
28. End Sub

复制代码

跳转到最佳答案楼层

爱疯

三公经费统计表2.rar (14.59 KB, 下载次数: 4)

2016-1-12 16:29 上传

点击文件名下载附件


好像你是希望求出第4，第5，第6行。
第4，不理解什么意思
第5，理解对吗？
第6，理解对吗？




Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = [d2].Address And IsDate(Target) Then Call tj(Target)
End Sub

Sub tj(t)
    Dim A, B, currentDate, currentMonth, currentYear, i, j, y, m

    '1）初值
    currentDate = t    '当前日期
    m = VBA.Month(t)    '当前月
    y = VBA.Year(t)    '当前年
    currentMonth = VBA.DateSerial(y, m, 1)    '当前月的第1天
    currentYear = VBA.DateSerial(y, 1, 1)   '当前年的第1天
    Application.EnableEvents = False
    [b4:g6] = ""
    A = Range("a1").CurrentRegion

    '2）统计
    For i = 8 To UBound(A) - 1
'        If A(i, 1) >= currentYear And A(i, 1) <= currentDate Then Call loops(A, i, 4)
        If A(i, 1) >= currentMonth And A(i, 1) <= currentDate Then Call loops(A, i, 5)
        If A(i, 1) >= currentYear And A(i, 1) <= currentDate Then Call loops(A, i, 6)
    Next

    '3）输出
    Range("a1").Resize(UBound(A), UBound(A, 2)) = A
    Application.EnableEvents = True
End Sub

Sub loops(A, i, x)
    Dim j
    For j = 2 To UBound(A, 2)
        A(x, j) = A(x, j) + A(i, j)
    Next
End Sub

grf1973

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim xrng As Range
   
3.     If Target.Address <> [d2].Address Then Exit Sub
   
4.     Dim brr(1 To 2, 1 To 6)
   
5.     r1 = Range("a:a").Find("汇总", , , , , xlNext).Row     '上一张表的汇总行
   
6.     r2 = Range("a:a").Find("汇总", , , , , xlPrevious).Row        '下一张表的汇总行
   
7.     rq = Target    '给定日期
   
8.     If rq = "全部" Then
   
9.         [b4].Resize(1, 6).Value = Cells(r2, 2).Resize(1, 6).Value
   
10.         [b5].Resize(1, 6).Value = ""
    
11.         [b6].Resize(1, 6).Value = Cells(r1, 2).Resize(1, 6).Value
    
12.     Else
    
13.         arr = Range("a8:g" & r1 - 1)
    
14.         nd = Year(rq)    '年度
    
15.         For i = 1 To UBound(arr)
    
16.             xrq = arr(i, 1) '日期
    
17.             If xrq <= rq And nd = Year(xrq) Then    '同年累计
    
18.                 For j = 1 To 6
    
19.                     brr(2, j) = brr(2, j) + arr(i, j + 1)
    
20.                     If rq = xrq Then brr(1, j) = arr(i, j + 1)    '本月数
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         Range("b5:g6") = brr
    
25.         Set xrng = Range("a:a").Find(nd, , , lookat:=xlWhole)    '全年预算
    
26.         If Not xrng Is Nothing Then [b4].Resize(1, 6).Value = Cells(xrng.Row, 2).Resize(1, 6).Value
    
27.     End If
    
28. End Sub

复制代码

feiaoli

爱疯 发表于 2016-1-12 16:30
好像你是希望求出第4，第5，第6行。
第4，不理解什么意思
第5，理解对吗？

谢谢老师关心，楼下grf1973 老师的代码给我解决了问题。

feiaoli

非常感谢grf1973 老师的帮助，解决了我很大问题。同时代码和表格干净漂亮，非常喜欢非常佩服!再次感谢！

feiaoli

grf1973 发表于 2016-1-12 16:42

grf1973 老师，D2单元格数据有效性没有和A列的添加一起变动呢？D2的数据有效性到了A35行向下就不显示日期了。我看老师的代码是到了1000行了，有效性看不出是哪里设置的，还请老师再给看一下，修改一下代码！万分感激！

grf1973

代码不用改。你直接日期添加进去好了，有效性会加进去的。但只能添加在A列“汇总”行前，因为是通过“汇总”设置终点的。
附件中在“汇总”前加了2个月，有效性自动补足了。