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

shenzhenyang

数据源都是从入库明细表和出库明细表汇取

根基P4：Q4的月份日期计算和E列物品名称判断，从入库明细表和出库明细表求出数据
H列是计算出上个月末的库存数，比如现在是4月，就是求出3月末的库存数量。
I列和J列就是这个月的进和出。
K列就是求出这个月的库存数，

L列和M列，就是求出总的进出，

现在都是用公式，打开运行慢，动下单元格就等表格运算1圈，请老师帮忙用VBA代码求出


谢谢您们。

ahaoge

使用字典和ADO组合查询汇总

ahaoge

Range("B5:M65536").ClearContents
    Dim r1!, i!, arr, crr(), drr()
    Dim k, t
    Dim d As Object
    r1 = Sheet3.Range("A65536").End(3).Row
    Set d = CreateObject("Scripting.DictionAry")
    arr = Sheet3.Range("B2:E" & r1)
    For i = 1 To UBound(arr)
        If arr(i, 2) <> "" Then
            d(arr(i, 2)) = arr(i, 1) & "," & arr(i, 3) & "," & arr(i, 4)
        End If
    Next i
    k = d.keys
    t = d.items
    s = d.Count
    Range("E5").Resize(s, 1) = Application.WorksheetFunction.Transpose(k)
    ReDim crr(1 To s, 1 To 1)
    ReDim drr(1 To s, 1 To 2)
    For i = 0 To s - 1
        crr(i + 1, 1) = Split(t(i), ",")(0)
        drr(i + 1, 1) = Split(t(i), ",")(1)
        drr(i + 1, 2) = Split(t(i), ",")(2)
    Next i
    Range("B5").Resize(UBound(crr), 1) = crr
    Range("F5").Resize(UBound(drr), 2) = drr
    r = Range("E65536").End(3).Row
    d.RemoveAll
    '-------------------使用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

ahaoge

前提条件:入库明细表和出库明细表的表头行的字符不能改变,否则SQL查询就会出错

shenzhenyang

ahaoge 发表于 2021-5-18 18:18
使用字典和ADO组合查询汇总

老师 我运行就出错呢

ahaoge

累计入库/出库查询数据有误,重新上传附件,以此为准,仅供参考

shenzhenyang

ahaoge 发表于 2021-5-18 18:28
累计入库/出库查询数据有误,重新上传附件,以此为准,仅供参考

重新下载了，还是一样出现图片错误

shenzhenyang

ahaoge 发表于 2021-5-18 18:28
累计入库/出库查询数据有误,重新上传附件,以此为准,仅供参考

老师，不用ADODB行不行，估计是我版本问题我是office2016   64位

Yalishanda30

shenzhenyang 发表于 2021-5-18 19:10
老师，不用ADODB行不行，估计是我版本问题我是office2016   64位

改一下就行了

ahaoge

由于Excel版本不同,需要修改数据库连接引擎代码,我用的是2007版本