双条件查找，返回多个值

风雨相随3

双条件查找，返回多个值? 双条件查找 返回多个值.rar (8.38 KB, 下载次数: 18)

2023-10-11 19:16 上传

点击文件名下载附件

重新编辑问题！

那位函数大神能否不用新函数TEXTJOIN,常规函数来完成。

蓝桥玄霜

查找的例子：

shiruiqiang

剑指E

。            

gwjkkkkk

请参考附件。。。

无关岁月

双条件查找 返回多个值.7z (16.36 KB, 下载次数: 29)

2023-10-11 20:04 上传

点击文件名下载附件

风雨相随3

gwjkkkkk 发表于 2023-10-11 19:34
请参考附件。。。

是这样的，但是宏里用了新函数，我的版本低，出现函数名错误。
老师能用旧函数写宏吗？

chxw68

参与一下。

zhangcheng6688

来个数组的，参与一下
Application.ScreenUpdating = False
arr = [a2].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
    If Len(arr(i, 1)) Then
       m = m + 1
       For j = 1 To UBound(arr, 2)
           brr(m, j) = arr(i, j)
       Next
       For k = i + 1 To UBound(arr)
           If Len(arr(k, 1)) Then
              If arr(k, 1) = arr(i, 1) And arr(k, 2) = arr(i, 2) Then
                 brr(m, 3) = brr(m, 3) & "," & arr(k, 3)
                 arr(k, 1) = vbNullString
               End If
            End If
        Next
    End If
Next
If m > 0 Then
  Range("i2:k10000").ClearContents
  [i2].Resize(m, 3) = brr
End If
Application.ScreenUpdating = True

680926

Sub t1()
Dim i As Integer
Dim arr
Dim brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:c8")
For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1) & arr(i, 2)) Then
        d(arr(i, 1) & arr(i, 2)) = arr(i, 3)
    Else
        d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) & "," & arr(i, 3)
    End If
Next

brr = Range("e1:f4")
For k = 2 To UBound(brr)
    Cells(k, 8) = d(brr(k, 1) & brr(k, 2))
Next
End Sub