输出汇总信息到另一个sheet

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.14
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     ReDim brr(1 To 1000, 1 To 3)
   
4.     With Sheets("分类汇总表")
   
5.         r = .Cells(Rows.Count, 3).End(3).Row
   
6.         arr = .[a1].Resize(r, 4)
   
7.         For i = 2 To UBound(arr)
   
8.             s = arr(i, 3)
   
9.             If Not d.exists(s) Then
   
10.                 d(s) = Split(arr(i, 2))
    
11.             End If
    
12.         Next
    
13.         t = d.items
    
14.         For i = 2 To UBound(arr)
    
15.             If Len(arr(i, 2)) = 0 Then
    
16.                 m = m + 1
    
17.                 brr(m, 1) = d(arr(i, 3))(0)
    
18.                 brr(m, 2) = arr(i, 3)
    
19.                 brr(m, 3) = arr(i, 4)
    
20.             End If
    
21.         Next
    
22.     End With
    
23.     With Sheets("汇总信息")
    
24.         .[b2:g1000] = ""
    
25.         .[b2].Resize(m, 3) = brr
    
26.     End With
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

yanglinzi

1. Sub 分包人汇总()
   
2. Dim arr, brr, crr, d, i, j, r, n
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet2.UsedRange
   
5. With Sheet1
   
6.     r = .Cells(Rows.Count, 2).End(xlUp).Row
   
7.     brr = .Range("a2:g" & r)
   
8. End With
   
9. ReDim crr(1 To UBound(brr), 1 To 6)
   
10. For i = 2 To UBound(brr)
    
11.     For j = 2 To UBound(arr)
    
12.         If InStr(brr(i, 2), arr(j, 1)) Then
    
13.             sa = arr(j, 1)
    
14.             If Not d.exists(sa) Then
    
15.                 n = n + 1
    
16.                 crr(n, 1) = Split(brr(i, 2), "")(0)
    
17.                 crr(n, 2) = arr(j, 1)
    
18.                 crr(n, 3) = brr(i, 4)
    
19.                 d(sa) = n
    
20.             Else
    
21.                 m = d(sa)
    
22.                 crr(m, 3) = crr(m, 3) + brr(i, 4)
    
23.             End If
    
24.         End If
    
25.     Next
    
26. Next
    
27. Stop
    
28. With Sheet5
    
29.     .UsedRange.Offset(1).Clear
    
30.     .[b2].Resize(n, 6) = crr
    
31. End With
    
32. End Sub
    

复制代码

yanglinzi

按分包人汇总

gwjkkkkk

Option Explicit

Sub 汇总()
    Dim dic As Object, ar, br, cr, i&
   
    Set dic = CreateObject("scripting.dictionary")
   
    ar = Sheets(3).[b1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 2)) Then
            dic(ar(i, 2)) = Array(Split(ar(i, 1))(0), ar(i, 2), ar(i, 3))
        Else
            If Len(ar(i, 1)) Then
                cr = dic(ar(i, 2))
                cr(2) = cr(2) + ar(i, 3)
                dic(ar(i, 2)) = cr
            End If
        End If
    Next i
   
    With Sheets(4)
        [b1].CurrentRegion.Offset(1).ClearContents
        [b2].Resize(dic.Count, 3) = Application.Rept(dic.items, 1)
        .Activate
    End With
End Sub

gwjkkkkk

参与一下。。。

李伟杰123

ykcbf1100 发表于 2024-5-14 14:52
参与一下。。。

没毛病，感谢老哥