双条件查找，返回多个值

风雨相随3

用函数也可以达到。 取值而不是求和.rar (8.3 KB, 下载次数: 5)

2023-10-12 19:46 上传

点击文件名下载附件

取值而不是求和2.rar (8.3 KB, 下载次数: 5)

2023-10-12 19:47 上传

点击文件名下载附件

zhangcheng6688

Sub test()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   ss = arr(i, 1) & arr(i, 2)
   If Not d.exists(ss) Then
      m = m + 1
      d(ss) = m
      For j = 1 To UBound(arr, 2)
         brr(m, j) = arr(i, j)
      Next
   Else
      p = d(ss)
      brr(p, 3) = brr(p, 3) & "," & arr(i, 3)
   End If
Next
[e2].Resize(m, UBound(brr, 2)) = brr
End Sub

ykcbf1100

参与一下，字典+数组经典用法。

ykcbf1100

代码如下：

1. Sub ykcbf()   '//2024.3.11
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Range("a1").CurrentRegion
   
6.     ReDim brr(1 To UBound(arr), 1 To 3)
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1) & "|" & arr(i, 2)
   
9.         If Not d.Exists(s) Then
   
10.             m = m + 1
    
11.             d(s) = m
    
12.             brr(m, 1) = arr(i, 1)
    
13.             brr(m, 2) = arr(i, 2)
    
14.             brr(m, 3) = arr(i, 3)
    
15.         Else
    
16.             r = d(s)
    
17.             brr(r, 3) = brr(r, 3) & "," & arr(i, 3)
    
18.         End If
    
19.     Next
    
20.     [e2:g5] = ""
    
21.     Range("e2").Resize(m, 3) = brr
    
22.     Range("e2").Resize(m, 3).Borders.LineStyle = 1
    
23.     Range("e2").Resize(m, 3).Sort [f2], 1
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码