年度1月到任意月的累加统计

quqiyuan

代码如下。。。。
    Public csdate
Sub 指标查询统计()
    '年度累加函数
    Application.ScreenUpdating = False
    Range("C3:i13").ClearContents
   
    Dim i As Long, j As Long, kk As Long
    Set ws = ThisWorkbook.Sheets("基础表")
    Set ws1 = ThisWorkbook.Sheets("统计表")
    arr1 = ws.Cells(1, 1).CurrentRegion.Value
    rq = Format(ws1.Range("d1").Value, "yyyy年m月")
    x = Application.Match(CStr(ws1.Range("d1")), Application.Index(arr1, , 1), 0)
    If IsError(x) Then MsgBox "没有此月份": Exit Sub
    dyzb = Get_ydzh(arr1, rq)
    syzb = Get_ydzh(arr1, rq, 1)
    tqdyzh = Get_ydzh(arr1, rq, 2)
    dylj = Get_ndzb(rq)
    qilj = Get_ndzb(rq, 1)
    dybj = Get_jdzb(rq)
    qibj = Get_jdzb(rq, 1)
    For i = 2 To UBound(arr1, 2)
        ws1.Cells(i + 1, 3) = dyzb(i)
        ws1.Cells(i + 1, 4) = syzb(i)
        ws1.Cells(i + 1, 5) = tqdyzh(i)
        ws1.Cells(i + 1, 6) = dybj(i)
        ws1.Cells(i + 1, 7) = qibj(i)
        ws1.Cells(i + 1, 8) = dylj(i) 'Get_ndzb(i)
        ws1.Cells(i + 1, 9) = qilj(i) 'Get_ndzb(i)
    Next i
    Application.ScreenUpdating = True
   
End Sub
Public Function Get_ydzh(arr1, ByVal indate As Variant, Optional inint As Integer = 0)
    '按日期查询取得当月、上月、上年当月数据函数
   
    'On Error Resume Next
    indate = Format(indate, "yyyy年m月")
    If inint = 1 Then
        indate = Format(DateAdd("m", -1, indate), "yyyy年m月")
    ElseIf inint = 2 Then
        indate = Format(DateAdd("yyyy", -1, indate), "yyyy年m月")
    Else
        indate = Format(indate, "yyyy年m月")
    End If
    kk = UBound(arr1, 2)
   
    For i = 1 To UBound(arr1)
        If Format(arr1(i, 1), "yyyy年m月") = indate Then
            ReDim arrtemp(1 To kk)
            For s = 1 To kk
                arrtemp(s) = arr1(i, s)                        'ws.Cells(i, s).Value
            Next
            Exit For
   
        End If
    Next
    Get_ydzh = arrtemp
End Function
Public Function Get_ndzb(ByVal indate As Variant, Optional inint As Integer = 0)
    indate1 = Format(indate, "yyyy年") & "1月"
    indate = Format(indate, "yyyy年m月")
    t = DateDiff("m", indate1, indate)
    If inint = 1 Then
        indate2 = Format(DateAdd("yyyy", -1, indate), "yyyy年m月")
        indate3 = Format(DateAdd("m", -t, indate2), "yyyy年m月")
    Else
        indate3 = Format(indate, "yyyy年") & "1月"
    End If
    Set ws = ThisWorkbook.Sheets("基础表")
    arr1 = ws.Cells(1, 1).CurrentRegion.Value
    kk = ws.UsedRange.Columns.Count
    For i = 1 To UBound(arr1)
        If Format(arr1(i, 1), "yyyy年m月") = indate3 Then
            data = ws.Range(ws.Cells(i, 1), ws.Cells(i + t, kk))
            Exit For
        End If
    Next i
    ReDim sum1(LBound(data, 2) To UBound(data, 2))
    ' 遍历每一列并累加
    For j = LBound(data, 2) To UBound(data, 2)
        For i = LBound(data, 1) To UBound(data, 1)
            sum1(j) = (sum1(j)) + (data(i, j))
        Next i
    Next j
    Get_ndzb = sum1
End Function
Public Function Get_jdzb(ByVal indate As Variant, Optional inint As Integer = 0)
    m = Format(indate, "m")
    m = Application.Match(1 * m, [{1,4,7,10}])
    indate1 = Format(indate, "yyyy年") & Application.Index([{1,4,7,10}], m) & "月"
    indate = Format(indate, "yyyy年m月")
    t = DateDiff("m", indate1, indate)
    If inint = 1 Then
        indate2 = Format(DateAdd("m", -3, indate), "yyyy年m月")
        m = Format(indate2, "m")
        m = Application.Match(1 * m, [{1,4,7,10}])
        indate3 = Format(indate2, "yyyy年") & Application.Index([{1,4,7,10}], m) & "月"
        t = 2
    Else
        indate3 = Format(indate, "yyyy年") & Application.Index([{1,4,7,10}], m) & "月"
    End If
    Set ws = ThisWorkbook.Sheets("基础表")
    arr1 = ws.Cells(1, 1).CurrentRegion.Value
    kk = ws.UsedRange.Columns.Count
    For i = 1 To UBound(arr1)
        If Format(arr1(i, 1), "yyyy年m月") = indate3 Then
            data = ws.Range(ws.Cells(i, 1), ws.Cells(i + t, kk))
            Exit For
        End If
    Next i
    ReDim sum1(LBound(data, 2) To UBound(data, 2))
    ' 遍历每一列并累加
    For j = LBound(data, 2) To UBound(data, 2)
        For i = LBound(data, 1) To UBound(data, 1)
            sum1(j) = (sum1(j)) + (data(i, j))
        Next i
    Next j
    Get_jdzb = sum1
End Function

dambcer

POVIT。。。。。。。

wzd8671

chxw68 发表于 2024-12-10 20:40
补充完整了。

老师，本季度及上一季度的有点问题，当选择2024年1月时，会累加1-3月的值，应该是只出1月的值。我搞了几天搞不定。希望重新修改一下。

ykcbf1100

参考其他老师的方法改写而已。
刚又看了一下，上季度的数据有点不太确定，如果日期是2024/2，那上季度算3个月呢还是算2个月呢？
附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.16
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Worksheets("基础表")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.         arr = .[a1].Resize(r, c)
   
8.     End With
   
9.     With Worksheets("统计表")
   
10.         rq = .Range("d1").Value
    
11.         yf = month(rq)
    
12.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         .UsedRange.Offset(2, 2).ClearContents
    
14.         brr = .[a1].Resize(r, 9)
    
15.         For i = 3 To UBound(brr)
    
16.             d(brr(i, 2)) = i
    
17.         Next
    
18.         For j = 2 To UBound(arr, 2)
    
19.             If d.exists(arr(1, j)) Then
    
20.                 m = d(arr(1, j))
    
21.                 For i = 2 To UBound(arr)
    
22.                     yf1 = month(arr(i, 1))
    
23.                     nf1 = Year(arr(i, 1))
    
24.                     If DateDiff("m", arr(i, 1), rq) = 0 Then brr(m, 3) = brr(m, 3) + arr(i, j)
    
25.                     If DateDiff("m", arr(i, 1), rq) = 1 Then brr(m, 4) = brr(m, 4) + arr(i, j)
    
26.                     If nf1 = Year(rq) - 1 And yf1 = yf Then brr(m, 5) = brr(m, 5) + arr(i, j)
    
27.                     If DateDiff("q", arr(i, 1), rq) = 0 And yf1 <= yf Then brr(m, 6) = brr(m, 6) + arr(i, j)
    
28.                     If DateDiff("q", arr(i, 1), rq) = 1 Then brr(m, 7) = brr(m, 7) + arr(i, j)
    
29.                     If nf1 = Year(rq) And yf1 <= yf Then brr(m, 8) = brr(m, 8) + arr(i, j)
    
30.                     If nf1 = Year(rq) - 1 And yf1 <= yf Then brr(m, 9) = brr(m, 9) + arr(i, j)
    
31.                 Next
    
32.             End If
    
33.         Next
    
34.         .[a1].Resize(r, 9) = brr
    
35.     End With
    
36.     Set d = Nothing
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "OK！"
    
39. End Sub
    

复制代码

chxw68

本季度不正确，上一季度是正确的。

chxw68

如果是统计上季度同期数据就用这个代码，比如现在选择的是2月份，本季度统计的是1-2月数据，上季度就统计去年10-11月数据。

wzd8671

chxw68 发表于 2024-12-16 08:53
本季度不正确，上一季度是正确的。

老师，是我的权限不够吗？为什么下载下来都是零字节！！！

chxw68

wzd8671 发表于 2024-12-16 15:07
老师，是我的权限不够吗？为什么下载下来都是零字节！！！

系统有问题了,你如果急需就加我QQ1025348239。

chxw68

重新上传一份。