出入库数量及库存数量汇总

baofa2

1. Sub test1() '纯练习一下，仅供测试……
   
2.   
   
3.   Worksheets("订单汇总表").Activate
   
4.   ActiveSheet.UsedRange.Offset(1).ClearContents
   
5.   Application.ScreenUpdating = False
   
6.   
   
7.   Dim ar, br, cr, Conn As Object, dict As Object, rs As Object
   
8.   Dim strConn As String, strFields As String, SQL As String, tb As String
   
9.   Dim A As String, B As String, C As String, i As Long, j As Long
   
10.   
    
11.   Set dict = CreateObject("Scripting.Dictionary")
    
12.   Set Conn = CreateObject("ADODB.Connection")
    
13.   
    
14.   If Application.Version < 12 Then
    
15.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
16.   Else
    
17.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
18.   End If
    
19.   Conn.Open strConn & ThisWorkbook.FullName
    
20.   
    
21.   For j = 1 To Worksheets.Count
    
22.     With Worksheets(j)
    
23.       If .Name Like "*库表明细" Then
    
24.         tb = .Name & "$A2:H" & .Range("A:H").Find("*", , xlValues, , xlByRows, xlPrevious).Row
    
25.         If strFields = "" Then
    
26.           strFields = Join(.[B2:F2&""], ",")
    
27.           A = "SELECT DISTINCT " & strFields & " FROM "
    
28.         End If
    
29.         i = InStr(.Name, "入库")
    
30.         A = A & IIf(i, "(", " UNION ALL ") & "SELECT " & strFields & " FROM [" & tb & "]" & IIf(i, "", ")")
    
31.         If i Then
    
32.           B = "SELECT " & strFields & ",SUM(入库数量) AS 入库总数量 FROM [" & tb & "] GROUP BY " & strFields
    
33.         Else
    
34.           C = "SELECT " & strFields & ",SUM(出库数量) AS 出库总数量 FROM [" & tb & "] GROUP BY " & strFields
    
35.           SQL = "SELECT 出库日期,SUM(出库数量) AS 出库总数量 FROM [" & tb & "] GROUP BY 出库日期"
    
36.         End If
    
37.         If Len(B) > 0 And Len(C) > 0 Then Exit For
    
38.       End If
    
39.     End With
    
40.   Next
    
41.   
    
42.   ar = Conn.Execute(SQL).GetRows
    
43.   For i = 0 To UBound(ar, 2)
    
44.     dict.Add CDate(Replace(ar(0, i), ".", "/")), i
    
45.   Next
    
46.   
    
47.   br = Split(strFields, ",")
    
48.   cr = br
    
49.   For i = 0 To UBound(br)
    
50.     br(i) = "a." & br(i) & "=b." & br(i)
    
51.     cr(i) = "a." & cr(i) & "=c." & cr(i)
    
52.   Next
    
53.   
    
54.   strFields = "123 AS 序号,a.*,NULL AS 订单数量,b.入库总数量,c.出库总数量,b.入库总数量-c.出库总数量 AS 库存数量"
    
55.   SQL = "SELECT " & strFields & " FROM ((" & A & ") a LEFT JOIN (" & B & ") b ON " & Join(br, " AND ") & ") LEFT JOIN (" & C & ") c ON " & Join(cr, " AND ")
    
56.   Set rs = Conn.Execute(SQL)
    
57.   
    
58.   With Range("A1")
    
59.     For i = 0 To rs.Fields.Count - 1
    
60.       .Offset(, i) = rs.Fields(i).Name
    
61.     Next
    
62.     .Offset(1).CopyFromRecordset rs
    
63.     With .Offset(, i)
    
64.       br = Range(.Offset(1), .End(xlToRight))
    
65.       For j = 1 To UBound(br, 2)
    
66.         If dict.Exists(br(1, j)) Then br(2, j) = ar(1, dict(br(1, j)))
    
67.       Next
    
68.       .Resize(UBound(br), UBound(br, 2)) = br
    
69.     End With
    
70.   End With
    
71.   
    
72.   rs.Close
    
73.   Set rs = Nothing
    
74.   Conn.Close
    
75.   Set Conn = Nothing
    
76.   Set dict = Nothing
    
77.   Application.ScreenUpdating = True
    
78.   Beep
    
79. End Sub

复制代码

东山飞鸽

学习了，谢谢大师！

jordanlive

ykcbf1100 发表于 2024-4-15 08:41
参与一下。。。。

老师，如果想入库明细表和出库明细表中做个模糊和精确查找功能，这代码能不能帮忙看看，

ykcbf1100

jordanlive 发表于 2024-4-16 09:03
老师，如果想入库明细表和出库明细表中做个模糊和精确查找功能，这代码能不能帮忙看看，

你的工作表事件会对查询区域产生影响，会出现错误提示。
查询代码不难写。

jordanlive

ykcbf1100 发表于 2024-4-16 09:09
你的工作表事件会对查询区域产生影响，会出现错误提示。
查询代码不难写。

那增加查询工表，在去查询入库表明细和出库表明细这样会不会对查询域产生影响

ykcbf1100

jordanlive 发表于 2024-4-16 09:22
那增加查询工表，在去查询入库表明细和出库表明细这样会不会对查询域产生影响

我先暂停了工作表事件，你自己视情决定。
二个明细表都写了查询代码（其实差不多），可以精确查询也可以模糊查询。

ykcbf1100

明细查询代码：

1. Sub 入库查询() '//2024.4.16
   
2.     With Sheets("入库表明细")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 8)
   
5.         Dim a, b, c
   
6.         c = 6
   
7.         ReDim a(1 To c), b(1 To c), ft(1 To c)
   
8.         For x = 1 To c - 1
   
9.             a(x) = CStr(.Cells(2, x + 9)): b(x) = x + 1
   
10.         Next
    
11.         a(c) = .Cells(2, 15): b(c) = 8
    
12.         ReDim brr(1 To UBound(arr), 1 To c + 1)
    
13.         For i = 3 To UBound(arr)
    
14.             fft = 1
    
15.             ft(c) = IIf(a(c) = Empty Or arr(i, b(c)) = a(c), 1, 0)
    
16.             fft = fft * ft(c)
    
17.             For x = 1 To c - 1
    
18.                 ft(x) = IIf(a(x) = Empty Or arr(i, b(x)) Like "*" & a(x) & "*", 1, 0)
    
19.                 fft = fft * ft(x)
    
20.             Next
    
21.             If fft = 1 Then
    
22.                 m = m + 1
    
23.                 For j = 1 To UBound(b)
    
24.                     brr(m, j) = arr(i, b(j))
    
25.                 Next
    
26.                 brr(m, c + 1) = arr(i, c + 1)
    
27.             End If
    
28.         Next
    
29.         If m > 0 Then
    
30.             .[j3:p10000].ClearContents
    
31.             .[j3].Resize(m, c + 1) = brr
    
32.         End If
    
33.         MsgBox "OK！"
    
34.     End With
    
35. End Sub

复制代码