急求助！按日汇总

CNS1993

谢谢大师抽出宝贵时间，帮修改代码一下，急用！
谢谢！！ 按日汇总求助.zip (197.32 KB, 下载次数: 13)

2018-8-8 19:03 上传

点击文件名下载附件

chaohuahch

你最好能说明一下，你要达到的目的。我看表格里面的代码，好像只用统计可用费用里面的。后面一堆代码，我就没有看了。

CNS1993

chaohuahch 发表于 2018-8-8 19:35
你最好能说明一下，你要达到的目的。我看表格里面的代码，好像只用统计可用费用里面的。后面一堆代码，我就 ...

是的，只统计16列的“客用费用”，谢谢！！！！

iwangyi

Sub ADO()
Set cn = CreateObject("ADODB.CONNECTION")
cn.Open "PROVIDER=MICROSOFT.JET.OLEDB.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
For Y = 3 To 95 Step 3
  RQ = Cells(2, Y)
  For Each MC In Range("A4:A20")
  Sql = "SELECT 入库数量,入库单价,入库金额 FROM [系统表2$] WHERE 日期= #" & RQ & "# AND 物品名称='" & MC & "'"
  Cells(MC.Row, Y).CopyFromRecordset cn.Execute(Sql)
  Next
Next
End Sub

iwangyi

附件********

CNS1993

iwangyi 发表于 2018-8-8 20:41
附件********

厉害！谢谢！
但，效果表除表头外，最先是空的。能用字典+数组就更好了。我对SQL一点也不了解！

chaohuahch

用字典有两个数据有问题。
第一个是西瓜，在7月27日，有两条数据
第二个是老盐菜 在7月19日，有两条数据
代码如下：

1. Sub test()
   
2. Dim arr, brr, i%, j%
   
3. Dim dic As Object, str As String, m As Double, n As Double
   
4. Dim RqDay%
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. With Sheets("系统表2")
   
7.     arr = .Range("a1").CurrentRegion
   
8.     For i = 2 To UBound(arr)
   
9.     If arr(i, 16) = "客用费用" Then
   
10.         RqDay = Day(arr(i, 3)): str = arr(i, 6)
    
11.         If arr(i, 9) <> "" Then
    
12.             If Not dic.exists(RqDay & str) Then
    
13.               dic(RqDay & str) = Array(arr(i, 9), arr(i, 10), arr(i, 11))
    
14.             End If
    
15.         Else
    
16.             If Not dic.exists(RqDay & str) Then
    
17.               dic(RqDay & str) = Array(arr(i, 12), arr(i, 13), arr(i, 14))
    
18.             End If
    
19.         End If
    
20.     End If
    
21.     Next i
    
22. End With
    
23. 
    
24. With Sheets("易耗品明细表")
    
25. brr = .Range("a1").CurrentRegion
    
26. 'm = 0: n = 0
    
27. For i = 3 To UBound(brr, 2) - 4 Step 3
    
28.    For j = 4 To UBound(brr)
    
29.        If Len(brr(2, i)) = 2 Then
    
30.            kk = Left(brr(2, i), 1) & brr(j, 1)
    
31.        Else
    
32.            kk = Left(brr(2, i), 2) & brr(j, 1)
    
33.        End If
    
34.            If dic.exists(kk) Then
    
35.                 brr(j, i) = dic(kk)(0)
    
36.                 brr(j, i + 1) = dic(kk)(1)
    
37.                 brr(j, i + 2) = dic(kk)(2)
    
38.            End If
    
39.    Next j
    
40. Next i
    
41. For i = 4 To UBound(brr)
    
42.    For j = 3 To UBound(brr, 2) - 4 Step 3
    
43.    brr(i, UBound(brr, 2) - 1) = brr(i, UBound(brr, 2) - 1) + brr(i, j)
    
44.    brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + brr(i, j + 2)
    
45.    Next j
    
46. Next i
    
47. .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = ""
    
48. .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
49. End With
    
50. 
    
51. 
    
52. 
    
53. End Sub
    

复制代码

CNS1993

chaohuahch 发表于 2018-8-8 21:45
用字典有两个数据有问题。
第一个是西瓜，在7月27日，有两条数据
第二个是老盐菜 在7月19日，有两条数据
...

谢谢！！太感谢了。
辛苦了！！

grf1973

1. Sub 易耗品明细表1() '经典的多条件汇总
   
2.     Dim d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Dim arr, brr(1 To 6000, 1 To 100)
   
5.     Dim i&
   
6.     Dim sr
   
7.      arr = Sheets("系统表2").Range("A2:P" & Sheets("系统表2").Range("A65536").End(xlUp).Row)
   
8. 
   
9.     k = 0
   
10.     For i = 1 To UBound(arr)
    
11.         If arr(i, 16) = "客用费用" Then
    
12.             sr = arr(i, 6)
    
13.             If Not d.Exists(sr) Then
    
14.                 k = k + 1
    
15.                 d(sr) = k
    
16.                 brr(k, 1) = sr
    
17.                 brr(k, 2) = arr(i, 8)
    
18.             End If
    
19.             p = d(sr)
    
20.             c = Day(arr(i, 3)) * 3
    
21.             brr(p, c) = brr(p, c) + arr(i, 9) + arr(i, 12)  '直接耗费  领用数量
    
22.             brr(p, c + 2) = brr(p, c + 2) + arr(i, 11) + arr(i, 14)   '直接耗费  领用金额
    
23.             brr(p, c + 1) = arr(i, 10)
    
24.             brr(p, 96) = brr(p, 96) + arr(i, 9) + arr(i, 12) '总数量
    
25.             brr(p, 97) = brr(p, 97) + arr(i, 11) + arr(i, 14) '总金额
    
26.         End If
    
27.     Next
    
28.     With Sheets("易耗品明细表")
    
29.         .[A4:AY100] = ""
    
30.         .Range("A4").Resize(k, 97) = brr
    
31.     End With
    
32. End Sub

复制代码

CNS1993

grf1973 发表于 2018-8-9 10:15

谢谢您！解了我的难事！！！