[已解决]求汇总表

WMJQWERR

求汇总表，函数或者VBA都可以，需要按照材料名称、规格、单价、单位四个条件汇总（月份入库表）的数量，（月份入库表）的材料是不断增加的，谢谢

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-1 15:34

1. Private Sub CommandButton1_Click()
   
2. Dim d, Arr, Brr()
   
3. Dim i&, k&, m&, sr As String
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Arr = Sheets("月份入库表").Range("C3:H" & Sheets("月份入库表").Range("B65536").End(xlUp).Row)
   
7. ReDim Brr(1 To UBound(Arr), 1 To 7)
   
8. For i = 1 To UBound(Arr)
   
9.     sr = Arr(i, 2) & Arr(i, 3) & Arr(i, 4) & Arr(i, 5)
   
10.     If d.Exists(sr) Then
    
11.        m = d(sr)
    
12.        Brr(m, 6) = Brr(m, 6) + Arr(i, 5)
    
13.     Else
    
14.         k = k + 1
    
15.         d(sr) = k
    
16.         Brr(k, 1) = k: Brr(k, 2) = Arr(i, 1): Brr(k, 3) = Arr(i, 2)
    
17.         Brr(k, 4) = Arr(i, 3): Brr(k, 5) = Arr(i, 4): Brr(k, 6) = Arr(i, 5)
    
18.         Brr(k, 7) = Arr(i, 6)
    
19.     End If
    
20. Next
    
21. With Sheets("汇总表")
    
22.     .Range("A3:G" & Rows.Count).ClearContents
    
23.     .Range("A3").Resize(UBound(Arr), 7) = Brr
    
24.     With .Range("A2").CurrentRegion.Borders
    
25.         .LineStyle = xlContinuous
    
26.         .Weight = xlThin
    
27.     End With
    
28. End With
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

跳转到最佳答案楼层

chart888

附件呢

安然Deng

可以使用透视表选择需要汇总的数据或者SUMIF0函数完成

WMJQWERR

安然Deng 发表于 2017-6-24 16:56
可以使用透视表选择需要汇总的数据或者SUMIF0函数完成

谢谢，数据表不好用，最好是函数或者vba，能帮忙把公式写一下吗？谢谢！！

安然Deng

表格附件上传下，我操作看看

WMJQWERR

安然Deng 发表于 2017-6-24 17:07
表格附件上传下，我操作看看

太粗心，忘记上传附件了，
现已上传，麻烦看一下，谢谢！！

xyzxyz07

Sub 汇总()
   Dim d, arr1, arr2()
   Set d = CreateObject("Scripting.Dictionary")
      arr1 = Sheets("月份入库表").Range("B3:H" & Sheets("月份入库表").Range("B65536").End(xlUp).Row)
      For i = 1 To UBound(arr1, 1)
         If d.Exists(arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5)) = False Then
            d(arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5)) = d.Count + 1
            ReDim Preserve arr2(1 To 6, 1 To d.Count)
            arr2(1, d.Count) = arr1(i, 2)
            arr2(2, d.Count) = arr1(i, 3)
            arr2(3, d.Count) = arr1(i, 4)
            arr2(4, d.Count) = arr1(i, 5)
            arr2(5, d(arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5))) = arr2(5, d(arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5))) + arr1(i, 6)
      End If
      Next i
   Sheets("汇总表").Range("B3").Resize(d.Count, 6) = Application.WorksheetFunction.Transpose(arr2)
End Sub

WMJQWERR

xyzxyz07 发表于 2017-6-25 13:55
Sub 汇总()
   Dim d, arr1, arr2()
   Set d = CreateObject("Scripting.Dictionary")

谢谢，能不能给我直接写在工作表里啊，VBA我不会，我把代码复制进去，没有反应再次感谢

WMJQWERR

有人吗

WMJQWERR

xyzxyz07 发表于 2017-6-25 13:55
Sub 汇总()
   Dim d, arr1, arr2()
   Set d = CreateObject("Scripting.Dictionary")

大神，这个我弄好了，但是只是汇总到月份入库表的第18行，18行以下的就不参与汇总了？？是怎么回事呢