用字典+数组或用数组模糊匹配汇总

VBA之恋

jiminyanyan 发表于 2017-8-20 13:46
Dim reg As New RegExp
正则…………。

嗯，谢了谢了

活在理想的世界

应该还有个李子吧？加上李子总数才能对上否则总数对不上的。
只做了一问，第二问跟第一问一样，只要再加个OR的语句就可以了。

1. Sub d()
   
2. Dim arr(), brr(), crr(), drr(), d As New Dictionary, w As WorksheetFunction
   
3. Set w = WorksheetFunction
   
4. k = Sheet1.Range("a1048576").End(3).Row - 1
   
5. h = Sheet1.Range("a1").End(2).Column
   
6. arr = Sheet1.Range("a2").Resize(k, h)
   
7. drr = w.Transpose(Sheet2.Range("f1").Resize(1, 3))
   
8. For i = 1 To UBound(arr)
   
9.     d(arr(i, 1) & "*" & arr(i, 3) & "*" & arr(i, 6)) = ""
   
10. Next
    
11. ReDim brr(1 To d.Count, 1 To 3)
    
12. ReDim crr(1 To d.Count, 1 To 3)
    
13. For Each i In d.Keys
    
14.     s = s + 1
    
15.     For j = 1 To 3
    
16.         brr(s, j) = Split(i, "*")(j - 1)
    
17.     Next
    
18. Next
    
19. For j = 1 To UBound(arr)
    
20.     For i = 1 To UBound(brr)
    
21.         For n = 1 To UBound(drr)
    
22.             If arr(j, 1) = brr(i, 1) And arr(j, 3) = brr(i, 2) And arr(j, 6) = brr(i, 3) And InStr(arr(j, 8), drr(n, 1)) > 0 Then
    
23.                 crr(i, n) = crr(i, n) + arr(j, 9)
    
24.             End If
    
25.         Next
    
26.     Next
    
27. Next
    
28. Sheet2.Range("f2").Resize(d.Count, 3) = crr
    
29. End Sub
    

复制代码

VBA之恋

活在理想的世界 发表于 2017-8-20 17:05
应该还有个李子吧？加上李子总数才能对上否则总数对不上的。
只做了一问，第二问跟第一问一样，只要再加个 ...

李子是故意放进去的，不做统计，这也从另一面证实代码的正确性

02761752696

学习学习，谢谢分享

blackttea1

学习学习，谢谢分享