没人可以帮帮忙吗?

linshanfeng1977

老师们,自已真的无能为力了,晚上再发一次

不知道为什么

这种体力活，你不如自己公式就可以了。

qingc0221

1. Private Sub Cmd_汇总_Click()
   
2.     Dim LastRow As Long, i As Long, j As Long
   
3.     Dim Total_收入 As Double, Total_支出 As Double
   
4.     Dim Conn As Object, Rst As Object
   
5.     Dim strSQL As String
   
6.    
   
7.     '清空原有查询
   
8.     LastRow = WorksheetFunction.Max(Cells(Rows.Count, 2).End(xlUp).Row, Cells(Rows.Count, 6).End(xlUp).Row)
   
9.     If LastRow > 10 Then
   
10.         Range(Rows(11), Rows(LastRow)).Delete
    
11.     End If
    
12.     Range("C6:C7").ClearContents
    
13.    
    
14.     Set Conn = CreateObject("ADODB.Connection")
    
15.     Set Rst = CreateObject("ADODB.RecordSet")
    
16.    
    
17.     If Application.Version = 11# Then
    
18.         Conn.Open "Provider=Microsoft.jet.Oledb.4.0;Extended Properties='Excel 8.0';Data Source=" & ThisWorkbook.FullName
    
19.     Else
    
20.         Conn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0';Data Source=" & ThisWorkbook.FullName
    
21.     End If
    
22.    
    
23.     strSQL = "SELECT 项目编号,项目名称,sum(收入金额) as 收入,sum(支出金额) as 支出 FROM [数据库$] " _
    
24.         & "WHERE 日期 BETWEEN #" & Range("C4").Value & "# AND #" & Range("C5").Value & "# " _
    
25.         & "GROUP BY 项目编号,项目名称 " _
    
26.         & "ORDER BY 项目编号;"
    
27.    
    
28.     Set Rst = Conn.Execute(strSQL)
    
29. 
    
30.     Rst.MoveFirst
    
31.     Do While Not Rst.EOF
    
32.         If Rst!收入 > 0 Then
    
33.             i = i + 1
    
34.             Cells(i + 10, 2) = Rst!项目编号
    
35.             Cells(i + 10, 3) = Rst!项目名称
    
36.             Cells(i + 10, 4) = Rst!收入
    
37.             Total_收入 = Total_收入 + Rst!收入
    
38.         End If
    
39.         If Rst!支出 > 0 Then
    
40.             j = j + 1
    
41.             Cells(j + 10, 6) = Rst!项目编号
    
42.             Cells(j + 10, 7) = Rst!项目名称
    
43.             Cells(j + 10, 8) = Rst!支出
    
44.             Total_支出 = Total_支出 + Rst!支出
    
45.         End If
    
46.         Rst.MoveNext
    
47.     Loop
    
48.     Cells(i + 11, 2) = "总计"
    
49.     Cells(i + 11, 4) = Total_收入
    
50. 
    
51.     Cells(j + 11, 6) = "总计"
    
52.     Cells(j + 11, 8) = Total_支出
    
53.    
    
54.     Range("B10").CurrentRegion.Borders.Weight = xlThin
    
55.     Range("F10").CurrentRegion.Borders.Weight = xlThin
    
56.     Conn.Close
    
57.     Set Conn = Nothing
    
58.     Set Rst = Nothing
    
59. End Sub

复制代码

qingc0221

不知道你C6和C7单元格的数据从哪里来的，所以只是简单的清空，没有再往里写数据

凌空一羽

我记得回过你几贴子的，详见附件及代码

1. Sub Lkyy()
   
2. Dim T_star, T_end, i%, t$, s%, R_inc%, R_exp%
   
3. qcz = Sheets("期初值").[c2]
   
4. T_star = [c4]
   
5. T_end = [c5]
   
6. Set d_inc = CreateObject("Scripting.Dictionary")  '收入
   
7. Set d_exp = CreateObject("Scripting.Dictionary")  '支出
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. With Sheet11
    
11.     '.Range("a1").CurrentRegion.Sort "日期", xlAscending, Header:=xlYes
    
12.     ar = .Range("a1").CurrentRegion
    
13.     For i = 2 To UBound(ar)
    
14.         If ar(i, 1) >= T_star And ar(i, 1) <= T_end Then
    
15.             t = ar(i, 9) & "," & ar(i, 10)
    
16.             If Len(ar(i, 24)) Then d_inc(t) = d_inc(t) + ar(i, 24)
    
17.             If Len(ar(i, 25)) Then d_exp(t) = d_exp(t) + ar(i, 25)
    
18.         End If
    
19.         If T_star > ar(i, 1) Then
    
20.             s = s + ar(i, 24) - ar(i, 25)
    
21.         End If
    
22.     Next
    
23. End With
    
24. Range("b11:h30,c6:c7").ClearContents
    
25. [c6] = s + qcz
    
26. Range("b11").Resize(d_inc.Count, 1) = Application.Transpose(d_inc.keys)
    
27. Range("b11").Resize(d_inc.Count, 1).TextToColumns comma:=True
    
28. Range("d11").Resize(d_inc.Count, 1) = Application.Transpose(d_inc.items)
    
29. Range("f11").Resize(d_exp.Count, 1) = Application.Transpose(d_exp.keys)
    
30. Range("f11").Resize(d_exp.Count, 1).TextToColumns comma:=True
    
31. Range("h11").Resize(d_exp.Count, 1) = Application.Transpose(d_exp.items)
    
32. R_inc = Range("b10").End(xlDown).Row
    
33. R_exp = Range("f10").End(xlDown).Row
    
34. Range("b" & R_inc + 1) = "合计"
    
35. Range("f" & R_exp + 1) = "合计"
    
36. Range("d" & R_inc + 1).Formula = "=sum(" & Range("d11:d" & R_inc).Address(0, 0) & ")"
    
37. Range("h" & R_exp + 1).Formula = "=sum(" & Range("h11:h" & R_exp).Address(0, 0) & ")"
    
38. [c7] = Range("d" & R_inc + 1) - Range("h" & R_exp + 1) + [c6]
    
39. Application.DisplayAlerts = True
    
40. Application.ScreenUpdating = True
    
41. Set d_inc = Nothing
    
42. Set d_exp = Nothing
    
43. End Sub

复制代码

linshanfeng1977

凌空一羽 发表于 2018-8-8 22:20
我记得回过你几贴子的，详见附件及代码

老师，本来想简单点做个例子，自已学习下，再修改下自己的文件（知识太匮乏）。看了下这么深的代码（下巴都掉下来了），确实太损体力了。难怪别人叫我用公式。本来我也想用公式又怕记录多时会很卡。非常感谢老师，您的帮忙！

linshanfeng1977

qingc0221 发表于 2018-8-8 22:18
不知道你C6和C7单元格的数据从哪里来的，所以只是简单的清空，没有再往里写数据

老师，真心感谢您！原以为没人帮忙了，这真得太损体力了。谢谢好心人

linshanfeng1977

凌空一羽 发表于 2018-8-8 22:20
我记得回过你几贴子的，详见附件及代码

老师，又出现个问题。溢出问题

凌空一羽

linshanfeng1977 发表于 2018-8-10 01:47
老师，又出现个问题。溢出问题

Sub Lkyy()
Dim T_star, T_end, i%, t$, R_inc%, R_exp%
qcz = Sheets("期初值").[c2]
T_star = [c4]
T_end = [c5]
Set d_inc = CreateObject("Scripting.Dictionary")  '收入
Set d_exp = CreateObject("Scripting.Dictionary")  '支出
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet11
    '.Range("a1").CurrentRegion.Sort "日期", xlAscending, Header:=xlYes
    ar = .Range("a1").CurrentRegion
    For i = 2 To UBound(ar)
        If ar(i, 1) >= T_star And ar(i, 1) <= T_end Then
            t = ar(i, 9) & "," & ar(i, 10)
            If Len(ar(i, 24)) Then d_inc(t) = d_inc(t) + ar(i, 24)
            If Len(ar(i, 25)) Then d_exp(t) = d_exp(t) + ar(i, 25)
        End If
        If T_star > ar(i, 1) Then
            s = s + ar(i, 24) - ar(i, 25)
        End If
    Next
End With
Range("b11:h30,c6:c7").ClearContents
[c6] = s + qcz
If d_inc.Count Then
    Range("b11").Resize(d_inc.Count, 1) = Application.Transpose(d_inc.keys)
    Range("b11").Resize(d_inc.Count, 1).TextToColumns comma:=True
    Range("d11").Resize(d_inc.Count, 1) = Application.Transpose(d_inc.items)
    R_inc = Range("b10").End(xlDown).Row
    Range("b" & R_inc + 1) = "合计"
    Range("d" & R_inc + 1).Formula = "=sum(" & Range("d11:d" & R_inc).Address(0, 0) & ")"
End If
If d_exp.Count Then
    Range("f11").Resize(d_exp.Count, 1) = Application.Transpose(d_exp.keys)
    Range("f11").Resize(d_exp.Count, 1).TextToColumns comma:=True
    Range("h11").Resize(d_exp.Count, 1) = Application.Transpose(d_exp.items)
    R_exp = Range("f10").End(xlDown).Row
    Range("f" & R_exp + 1) = "合计"
    Range("h" & R_exp + 1).Formula = "=sum(" & Range("h11:h" & R_exp).Address(0, 0) & ")"
End If
[c7] = Range("d" & R_inc + 1) - Range("h" & R_exp + 1) + [c6]
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set d_inc = Nothing
Set d_exp = Nothing
End Sub