多表多条件汇总

yanglaicun

已知“入库”和“出库”为数据源，用“VBA”生成“汇总”数据。希望各位大虾帮忙，谢谢！

liulang0808

Sub 按钮1_Click()
    Set sh = ActiveSheet
    Application.ScreenUpdating = False
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    arr = Sheets("入库").UsedRange
    For j = 2 To UBound(arr)
        d1(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) = d1(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) + arr(j, 3)
        d2(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) = d2(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) + arr(j, 4)
    Next j
    sh.UsedRange.Offset(2).ClearContents
    For j = 0 To d1.Count - 1
        Cells(j + 3, 1).Resize(1, 2) = Split(d1.keys()(j), "###")
        Cells(j + 3, 3) = d1.items()(j)
        Cells(j + 3, 4) = d2.items()(j)
    Next j
   
    arr = Sheets("出库").UsedRange
    d1.RemoveAll
    d2.RemoveAll
    For j = 2 To UBound(arr)
        d1(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) = d1(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) + arr(j, 3)
        d2(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) = d2(Format(arr(j, 1), "yyyy年m月") & "###" & arr(j, 2)) + arr(j, 4)
    Next j
    r = Cells(Rows.Count, 1).End(3).Row + 1
    For j = 3 To Cells(Rows.Count, 1).End(3).Row
        aa = Format(Cells(j, 1), "yyyy年m月") & "###" & Cells(j, 2)
        If d1.exists(Format(Cells(j, 1), "yyyy年m月") & "###" & Cells(j, 2)) Then
            Cells(j, 5) = d1(Format(Cells(j, 1), "yyyy年m月") & "###" & Cells(j, 2))
            Cells(j, 6) = d2(Format(Cells(j, 1), "yyyy年m月") & "###" & Cells(j, 2))

        End If
    Next j
   
    Application.ScreenUpdating = True
End Sub

liulang0808

如果的月份及项目不少于出库，可以获取正常的结果，如果出库多需要变通

一指禅62

1. Sub 库存()
   
2.     Dim arr, i&, brr(), n%, d As Object, s$
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("入库").Range("a1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         s = Format(arr(i, 1), "yyyy年mm月") & "|" & arr(i, 2)
   
7.         If Not d.Exists(s) Then
   
8.             n = n + 1: ReDim Preserve brr(1 To 4, 1 To n)
   
9.             d(s) = n
   
10.             brr(1, n) = arr(i, 3)
    
11.             brr(2, n) = arr(i, 4)
    
12.         Else
    
13.             brr(1, d(s)) = brr(1, d(s)) + arr(i, 3)
    
14.             brr(2, d(s)) = brr(2, d(s)) + arr(i, 4)
    
15.         End If
    
16.     Next
    
17.    
    
18.     arr = Sheets("出库").Range("a1").CurrentRegion
    
19.     For i = 2 To UBound(arr)
    
20.         s = Format(arr(i, 1), "yyyy年mm月") & "|" & arr(i, 2)
    
21.         If Not d.Exists(s) Then
    
22.             n = n + 1: ReDim Preserve brr(1 To 4, 1 To n)
    
23.             d(s) = n
    
24.             brr(3, n) = arr(i, 3)
    
25.             brr(4, n) = arr(i, 4)
    
26.         Else
    
27.             brr(3, d(s)) = brr(3, d(s)) + arr(i, 3)
    
28.             brr(4, d(s)) = brr(4, d(s)) + arr(i, 4)
    
29.         End If
    
30.     Next
    
31.    
    
32.     Sheet3.Select
    
33.     Range("A3:M65536").ClearContents
    
34.     Range("A3").Resize(d.Count, 2) = WorksheetFunction.Transpose(d.keys)
    
35.     Range("C3").Resize(d.Count, 4) = WorksheetFunction.Transpose(brr)
    
36.     Range("A:A").Replace "|*", ""
    
37.     Range("B:B").Replace "*|", ""
    
38. End Sub

复制代码

一指禅62

工作簿1.rar (17.62 KB, 下载次数: 81)

2016-4-30 10:35 上传

点击文件名下载附件

昨夜星辰昨夜风

1. Sub 汇总()
   
2.     Dim CNN As Object
   
3.     Dim SQL As String
   
4.     Set CNN = CreateObject("ADODB.connection")
   
5.     CNN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR = yes';Data Source=" & ThisWorkbook.FullName
   
6.     SQL = "select d.年月,d.物料代码,sum(d.入库数量),sum(d.入库金额),sum(d.出库数量),sum(d.出库金额) from (select str(year(日期))+'年'+trim(str(month(日期)))+'月' as 年月,物料代码,数量 as 入库数量,金额 as 入库金额,0 as 出库数量,0 as 出库金额 from [入库$] union all select str(year(日期))+'年'+trim(str(month(日期)))+'月' as 年月,物料代码,0 as 入库数量,0 as 入库金额,数量 as 出库数量,金额 as 出库金额 from [出库$]) as D where d.年月<>''group by d.年月,d.物料代码"
   
7.     Sheets("汇总").Range("A3").CopyFromRecordset CNN.Execute(SQL)
   
8.     CNN.Close
   
9.     Set CNN = Nothing
   
10. End Sub

复制代码

yanglaicun

谢谢各位！如果改成这样呢？见附件，谢谢！

yanglaicun

昨夜星辰昨夜风 发表于 2016-4-30 12:13

谢谢！
这句调试不过
CNN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR = yes';Data Source=" & ThisWorkbook.FullName

yanglaicun

liulang0808 发表于 2016-4-30 09:49
Sub 按钮1_Click()
    Set sh = ActiveSheet
    Application.ScreenUpdating = False

非常谢谢！
换成7楼的文件如何处理？

liulang0808

yanglaicun 发表于 2016-4-30 12:40
非常谢谢！
换成7楼的文件如何处理？

根据表格格式。代码对应调整就可以了