请教如何 用VBA查找相同的名称，相加其数量

shenjianrong163

如果是4-10列都有数据汇总，代码如下：
Sub test()
    Dim r%, i%, j%
    Dim arr, brr()
    Dim d
    Set d = CreateObject("Scripting.dictionary")
    With Worksheets("700")
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = .Range("B2:J" & r)
        For i = 1 To UBound(arr)
            If d.Exists(arr(i, 1)) = False Then
                d(arr(i, 1)) = d.Count + 1
                ReDim Preserve brr(1 To 9, 1 To d.Count)
                brr(1, d.Count) = arr(i, 1)
            End If
            For j = 3 To 9
                    brr(j, d(arr(i, 1))) = brr(j, d(arr(i, 1))) + arr(i, j)
            Next
        Next
        .Cells(r + 3, 2).Resize(d.Count, 9) = Application.Transpose(brr)
    End With
    Set d = Nothing
End Sub

Chiyuen

shenjianrong163 发表于 2020-1-29 11:37
如果是4-10列都有数据汇总，代码如下：
Sub test()
    Dim r%, i%, j%

我后来用vlookup从数据源的表内查找了中间那几列的数据对应过来，因为那几列的数据，不是要相加的，是文本

answer6141

1. Option Explicit
   
2. 
   
3. Sub test()
   
4. Dim i, irow As Integer
   
5. Dim d As Object
   
6. Dim arr, brr, crr
   
7. irow = Cells(1, 2).End(xlDown).Row
   
8. Range("b" & irow + 1 & ":j65536").ClearComments
   
9. arr = Range("b1:j" & irow)
   
10. Set d = CreateObject("scripting.dictionary")
    
11. Debug.Print UBound(arr, 2)
    
12. For i = 1 To UBound(arr)
    
13.     d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 9)
    
14. Next
    
15. brr = d.keys
    
16. ReDim crr(0 To UBound(brr), 0 To UBound(arr) - 1)
    
17. For i = 0 To UBound(brr)
    
18.     crr(i, 0) = brr(i)
    
19.     crr(i, 8) = d(brr(i))
    
20. Next
    
21. Range("b" & irow + 1 & ":j65536").ClearComments
    
22. Range("b" & irow).Offset(3).Resize(UBound(crr) + 1, UBound(crr, 2) + 1) = crr
    
23. End Sub
    
24. 有用请赏花

复制代码

answer6141

源文件