如何用VBA在明细账中自动加上本月合计，本年累计，全部累计

sxbjzjf110

数组做了一下。

limonet

关键字：filter+getrows+find

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Xrr As Variant, Yrr As Variant, Arr As Variant, Brr As Variant, Crr As Variant, Rst As Object, Rng As Range, i%
    Xrr = Array("Total", "借", "贷")
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select 9999 As Class,'全部合计' As Total,Sum(借方金额) as 借,Sum(贷方金额) As 贷 From [Sheet1$]"
    StrSQL = StrSQL & " Union All Select Year(凭证日期) As Class,'本年累计',Sum(借方金额),Sum(贷方金额) From [Sheet1$] Group By Year(凭证日期)"
    StrSQL = StrSQL & " Union All Select 月份,'本月合计',Sum(借方金额),Sum(贷方金额) From [Sheet1$] Group By 月份"
    Set Rst = Cn.Execute(StrSQL)
    Yrr = Rst.GetRows(, , "Class")
    Rst.Filter = "Class=9999": Crr = Application.Transpose(Rst.GetRows(, , Xrr))
    For i = 4 To UBound(Yrr, 2)
        If i < UBound(Yrr, 2) Then
            Set Rng = Cells.Find(Yrr(0, i + 1))
        Else
            Set Rng = Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, "B")
        End If
        Rng.EntireRow.Resize(3).Insert
        Rst.Filter = "Class=" & Left(Yrr(0, i), 4): Brr = Application.Transpose(Rst.GetRows(, , Xrr))
        Rst.Filter = "Class=" & Yrr(0, i): Arr = Application.Transpose(Rst.GetRows(, , Xrr))
        Rng.Offset(-3, 2).Resize(1, 3) = Arr: Rng.Offset(-2, 2).Resize(1, 3) = Brr: Rng.Offset(-1, 2).Resize(1, 3) = Crr
    Next i
End Sub

709320636

非常感谢高手相助，我用的是2003表格打开，运行宏时，第六行执行不了，就是”cn.open........“”这一句。不知如何解决，还请莫奈老师再帮看下。

limonet

替换这句：
Cn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName

chxw68

借楼主的问题练练手。

ykcbf1100

chxw68 发表于 2024-3-19 16:23
借楼主的问题练练手。

chxw68老师，代码运行有错误提示，那个rq设置再看看？

chxw68

谢谢hykcbf1100老师提醒！已经修改好了。

ykcbf1100

向chxw68老师学一个！，用字典代替数组zrr

ykcbf1100

向chxw68老师学习。

1. Sub test2() '//2024.3.20
   
2.     Dim arr,  hj(1 To 3, 1 To 6)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     hj(1, 2) = "本月合计"
   
5.     hj(2, 2) = "本年累计"
   
6.     hj(3, 2) = "全部累计"
   
7.     With Worksheets("sheet1")
   
8.         .AutoFilterMode = False
   
9.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
10.         arr = .Range("a1:f" & r)
    
11.         Set rng = .Rows(r + 1)
    
12.         For i = 2 To UBound(arr)
    
13.             If InStr(arr(i, 2), "计") Then
    
14.                 Set rng = Union(rng, .Rows(i))
    
15.             End If
    
16.         Next
    
17.         rng.Delete
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         .Range("a2:f" & r).Sort .[a2], 1
    
20.         arr = .Range("a1:f" & r)
    
21.         n = 0
    
22.         For i = 2 To UBound(arr)
    
23.             If arr(i, 2) <> arr(i - 1, 2) Then
    
24.                 n = n + 1
    
25.                 d(n) = i
    
26.             End If
    
27.         Next
    
28.         ReDim brr(1 To UBound(arr) + n * 3, 1 To UBound(arr, 2))
    
29.         m = 0
    
30.         On Error Resume Next
    
31.         For k = 1 To d.Count
    
32.             r1 = d(k)
    
33.             If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
34.             For j = 5 To 6
    
35.                 hj(1, j) = 0
    
36.             Next
    
37.             If k > 1 Then
    
38.                 If Year(arr(r1, 1)) <> Year(arr(r2, 1)) Then
    
39.                     For j = 5 To 6
    
40.                         hj(2, j) = 0
    
41.                     Next
    
42.                 End If
    
43.             End If
    
44.             For i = r1 To r2
    
45.                 m = m + 1
    
46.                 For j = 1 To UBound(arr, 2)
    
47.                     brr(m, j) = arr(i, j)
    
48.                 Next
    
49.                 For j = 5 To 6
    
50.                     hj(1, j) = hj(1, j) + arr(i, j)
    
51.                 Next
    
52.             Next
    
53.             For x = 2 To 3
    
54.                 For j = 5 To 6
    
55.                     hj(x, j) = hj(x, j) + hj(1, j)
    
56.                 Next
    
57.             Next
    
58.             For x = 1 To 3
    
59.                 m = m + 1
    
60.                 For j = 1 To UBound(hj, 2)
    
61.                     brr(m, j) = hj(x, j)
    
62.                 Next
    
63.             Next
    
64.         Next
    
65.         .Range("E:F").NumberFormatLocal = "0.00"
    
66.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
67.         ActiveWindow.DisplayZeros = False
    
68.     End With
    
69. End Sub
    

复制代码