根据日期段，从Access内计算并将结果导入到Excel

182197315

楼主有几个输入错误
Dim arr, ks, js, kc, rk, ck
Sub lqxs()
Dim cnn, i&, aa, j&, brr, n&
Dim sql As String
Dim myPath As String, d, k, t, kk, tt, ii&
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("adodb.connection")
ks = [b1].Value: js = [b2].Value
myPath = ThisWorkbook.Path & "\数据库.accdb"
On Error GoTo Errmsg
cnn.Open "provider=microsoft.ace.oledb.12.0;data source=" & myPath
sql = "select * from 数据源"
arr = cnn.Execute(sql).getrows
For i = 0 To UBound(arr, 2)
    x = arr(2, i): y = arr(3, i)
    If d.exists(x) = False Then Set d(x) = CreateObject("scripting.dictionary")
    d(x)(y) = d(x)(y) & i & ","
Next
k = d.keys: t = d.items
ReDim brr(1 To UBound(arr) + 1, 1 To 6)
For i = 0 To UBound(k)
    kk = t(i).keys: tt = t(i).items
    For ii = 0 To UBound(kk)
        kc = 0: rk = 0: ck = 0
        n = n + 1
        brr(n, 1) = k(i): brr(n, 2) = kk(ii)
        tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
        If InStr(tt(ii), ",") Then
            aa = Split(tt(ii), ",")
            For j = 0 To UBound(aa)
                Call pd(aa(j))
            Next
        Else
            Call pd(tt(ii))
        End If
        brr(n, 3) = kc: brr(n, 4) = rk: brr(n, 5) = ck
        brr(n, 6) = kc + rk - ck
    Next
Next
[a5].Resize(500, 6).ClearContents
[a5].Resize(n, 6) = brr
Exit Sub
Errmsg:
MsgBox Err.Description, , "错误报告"
End Sub

Sub pd(nn)
Select Case arr(0, nn)
    Case Is < ks
        If arr(5, nn) = "入库" Then
            kc = kc + arr(6, nn)
        Else
            kc = kc - arr(6, nn)
        End If
    Case ks To js
        If arr(5, nn) = "入库" Then
            rk = rk + arr(6, nn)
        Else
            ck = ck + arr(6, nn)
        End If
End Select
End Sub

999110022

30楼的兄弟高手！佩服。

ruuw

999110022 发表于 2019-10-24 08:50
这两天都是早班，白天上班弄不了，晚上回家还要陪孩子玩。周末吧。正好想想楼上的提出来的sql语句的事。
...

现在数据库数据不多，以后肯定会有许多，可以说是成千上万。

ruuw

opiona 发表于 2019-10-24 11:30
一句SQL搞定

谢谢！真是高高手，解决我的问题了，非常感谢。
同时也谢谢各位高手对于我的帮助。

opiona

ruuw 发表于 2019-10-25 07:38
谢谢！真是高高手，解决我的问题了，非常感谢。
同时也谢谢各位高手对于我的帮助。

那就送朵花吧

ruuw

opiona 发表于 2019-10-25 10:53
那就送朵花吧

在哪送花？怎么送？

ruuw

opiona 发表于 2019-10-25 10:53
那就送朵花吧

刚弄清楚怎么送花的，谢谢帮忙。