|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
楼主有几个输入错误
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
|
|