[已解决]求汇总表

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)

End If
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)
Next i
Sheets("汇总表").Range("B3").Resize(d.Count, 6) = Application.WorksheetFunction.Transpose(arr2)
End Sub

chart888

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

复制代码