请老师帮忙用VBA，现在数据多函数运行很慢

ahaoge

很多公式有点累赘,比如进出库表的I4,J4

ahaoge

很多公式有点累赘,比如进出库表的I4,J4,直接橡下面这样不行吗?
I4=P3&"月入库"
J4=P3&"月出库"

shenzhenyang

Yalishanda30 发表于 2021-5-18 19:28
改一下就行了

    'r1 = Sheet3.Range("A65536").End(3).Row
    r1 = Sheet1.Range("E65536").End(3).Row
    Set d = CreateObject("Scripting.DictionAry")
    'arr = Sheet3.Range("B2:E" & r1)
    arr = Sheet1.Range("B5:B", "E5:E" & r1)


请问这个获取品名我想改成第一张表，怎么改，现在获取品名是第3张表，里面到时会有很多名，但不是每个名会有入库，我的意思就是想根据入库的品名，谢谢帮我看怎么改

shenzhenyang

ahaoge 发表于 2021-5-18 20:27
很多公式有点累赘,比如进出库表的I4,J4,直接橡下面这样不行吗?
I4=P3&"月入库"
J4=P3&"月出库"

'r1 = Sheet3.Range("A65536").End(3).Row
    r1 = Sheet1.Range("E65536").End(3).Row
    Set d = CreateObject("Scripting.DictionAry")
    'arr = Sheet3.Range("B2:E" & r1)
    arr = Sheet1.Range("B5:B", "E5:E" & r1)


请问这个获取品名我想改成第一张表，怎么改，现在获取品名是第3张表，里面到时会有很多名，但不是每个名会有入库，我的意思就是想根据入库的品名，谢谢帮我看怎么改

shenzhenyang

ahaoge 发表于 2021-5-18 18:19
Range("B5:M65536").ClearContents
    Dim r1!, i!, arr, crr(), drr()
    Dim k, t

  '-------------------使用ADO查询-------------------------------------------------------------------------------
    Set cn = CreateObject("ADODB.ConneCtion")  '创建excel数据库连接
    Set rs = CreateObject("ADODB.Recordset")  '创建excel数据库连接
    cn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    r1 = Sheet1.Range("B65536").End(3).Row
    r2 = Sheet2.Range("B65536").End(3).Row
    For i = 5 To r
        Cells(i, "I").CopyFromRecordset cn.Execute("Select sum(数量) from [入库明细$B4:L" & r1 & "] where 类别='" & Cells(i, "B") & "' and 物品名称='" & Cells(i, "E") & "' and year(入库时间)=" & Year([P4]) & " and month(入库时间)=" & Month([P4]))
        Cells(i, "J").CopyFromRecordset cn.Execute("Select sum(数量) from [出库明细$B4:L" & r2 & "] where 类别='" & Cells(i, "B") & "' and 物品名称='" & Cells(i, "E") & "' and year(出库时间)=" & Year([P4]) & " and month(出库时间)=" & Month([P4]))
        Cells(i, "L").CopyFromRecordset cn.Execute("Select sum(数量) from [入库明细$B4:L" & r1 & "] where 类别='" & Cells(i, "B") & "' and 物品名称='" & Cells(i, "E") & "'")
        Cells(i, "M").CopyFromRecordset cn.Execute("Select sum(数量) from [出库明细$B4:L" & r2 & "] where 类别='" & Cells(i, "B") & "' and 物品名称='" & Cells(i, "E") & "'")
    Next i
    '--------------------------------------------------------------------------------------------------------------
    DateUp = DateAdd("d", -1, [P4])
    Range("K5:K" & r) = "=L5-M5"
    Range("H5:H" & r) = "=(L5-I5)-(M5-J5)"
    Range("E" & r + 1) = "合计"
    Range("H" & r + 1 & ":M" & r + 1) = "=SUM(H5:H" & r & ")"
    Range("B5:M" & r + 1).Borders.LineStyle = 1


老师这个ADO，能改成直接代码，把这个代码用到表里运行下，好慢，比原先公式更慢，估计是代码一直填写公式造成慢的问题

opel-wong

时间比较紧，匆匆忙忙的凑一个，
经测试，貌似结果正确，
代码如下，供参考：

shenzhenyang

opel-wong 发表于 2021-5-18 22:27
时间比较紧，匆匆忙忙的凑一个，
经测试，貌似结果正确，
代码如下，供参考：

谢谢您，非常感谢

shenzhenyang

opel-wong 发表于 2021-5-18 22:27
时间比较紧，匆匆忙忙的凑一个，
经测试，貌似结果正确，
代码如下，供参考：

1. Sub 进出库汇总最新()
   
2.     Dim ARR, Ar, Br, i&, j&, mStr$, m&, Sum1#, Sum2#, T1 As Date: T1 = Timer
   
3.     Ar = Sheet1.Range("b4").CurrentRegion.Value '入库明细
   
4.     Br = Sheet2.Range("b4").CurrentRegion.Value '出库明细
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     With Sheet6 '进出库汇总
   
8.          .Activate
   
9.          Dim s1 As Date: s1 = .Range("o1").Value '月初日期上月，
   
10.          Dim e1 As Date: e1 = .Range("Q1").Value '上月，月末日期
    
11.          Dim s2 As Date: s2 = .Range("P4").Value '本月，月初日期
    
12.          Dim e2 As Date: e2 = .Range("Q4").Value '本月，月末日期
    
13.     End With
    
14.     ReDim ARR(1 To UBound(Ar) + UBound(Br), 1 To 12)
    
15.     Dim d As Object: Set d = CreateObject("scripting.Dictionary")
    
16.     For i = 2 To UBound(Ar)
    
17.        If Len(Ar(i, 1)) > 0 And Len(Ar(i, 4)) > 0 And Len(Ar(i, 6)) > 0 Then
    
18.            If Ar(i, 5) = 0 Then Ar(i, 5) = Empty
    
19.            mStr = Ar(i, 1) & "," & Ar(i, 4) & "," & Ar(i, 5) & "," & Ar(i, 6)
    
20.            If Not d.Exists(mStr) Then
    
21.                m = m + 1
    
22.                d(mStr) = m
    
23.                ARR(m, 1) = Ar(i, 1)
    
24.                ARR(m, 2) = m
    
25.                ARR(m, 3) = Empty
    
26.                ARR(m, 4) = Ar(i, 4)
    
27.                ARR(m, 5) = Ar(i, 5)
    
28.                ARR(m, 6) = Ar(i, 6)
    
29.            End If
    
30.        End If
    
31.     Next
    
32.     For i = 1 To UBound(ARR)
    
33.         Sum1 = 0: Sum2 = 0
    
34.         For j = 2 To UBound(Ar)
    
35.             If Len(Ar(j, 3)) > 0 And IsDate(Ar(j, 3)) Then
    
36.                 If ARR(i, 1) = Ar(j, 1) And ARR(i, 4) = Ar(j, 4) Then
    
37.                    If Ar(j, 3) >= s1 And Ar(j, 3) <= e1 Then Sum1 = Sum1 + Val(Ar(j, 7))
    
38.                    If Ar(j, 3) >= s2 And Ar(j, 3) <= e2 Then ARR(i, 8) = ARR(i, 8) + Val(Ar(j, 7))
    
39.                    ARR(i, 11) = ARR(i, 11) + Val(Ar(j, 7))
    
40.                 End If
    
41.             End If
    
42.          Next
    
43.          For j = 2 To UBound(Br)
    
44.             If Len(Br(j, 3)) > 0 And IsDate(Br(j, 3)) Then
    
45.                If ARR(i, 1) = Br(j, 1) And ARR(i, 4) = Br(j, 4) Then
    
46.                   If Br(j, 3) >= s1 And Br(j, 3) <= e1 Then Sum2 = Sum2 + Val(Br(j, 7))
    
47.                   If Br(j, 3) >= s2 And Br(j, 3) <= e2 Then ARR(i, 9) = ARR(i, 9) + Val(Br(j, 7))
    
48.                   ARR(i, 12) = ARR(i, 12) + Val(Br(j, 7))
    
49.                End If
    
50.             End If
    
51.          Next
    
52.          ARR(i, 7) = Sum1 - Sum2
    
53.          ARR(i, 10) = ARR(i, 11) - ARR(i, 12)
    
54.     Next
    
55.     For i = 1 To UBound(ARR)
    
56.         For j = 7 To 12
    
57.             If Len(ARR(i, j)) = 0 Then ARR(i, j) = 0
    
58.         Next
    
59.      Next
    
60.      Range("b5:N1048576").ClearContents
    
61.      Range("B5").Resize(m, 12).Value = ARR
    
62.      Application.ScreenUpdating = True
    
63. 
    
64.       
    
65.      MsgBox "数据已统计完成，用时约:" & Format(Timer - T1, "0.00") & "秒!"
    
66. End Sub
    
67. 
    
68. 
    
69. 
    
70. 
    
71. 
    
72. 
    
73. 
    
74. 
    
75. 
    
76. 
    

复制代码

老师，这个你上次帮我写的代码，现在数据多，运行很慢，帮我优化看能不能提升速度，谢谢

shenzhenyang

opel-wong 发表于 2021-5-18 22:27
时间比较紧，匆匆忙忙的凑一个，
经测试，貌似结果正确，
代码如下，供参考：

老师麻烦你在帮我看看代码怎么运算快，谢谢你了

opel-wong

shenzhenyang 发表于 2021-12-4 09:22
老师麻烦你在帮我看看代码怎么运算快，谢谢你了

把你的大数据放上来，目测10万数据，压力不大。
如果有10万+以上的数据，就放上来，我再想想其它的办法。