一对多匹配求助代码的写法

彼德仔

求助用vba 的方法

周义坤

1. Function testjoin(a As Range, b As String)
   
2.    Dim c As Variant, i As Long, t As String
   
3.       c = a
   
4.       For i = 1 To UBound(c)
   
5.         If c(i, 1) = b Then
   
6.           t = t & "," & c(i, 2)
   
7.         End If
   
8.       Next i
   
9. testjoin = Mid(t, 2)
   
10. End Function
    

复制代码

pureshadow

1. =TEXTJOIN(",",,IF(A$1:A$5=H1,B$1:B$5,""))

复制代码

roych

请参考：http://www.office-cn.net/thread-96091-1-1.html

pureshadow

代码版：

1. Sub Sample()
   
2. Dim MyRow As Long, i As Long
   
3. Dim MyStr As String
   
4. For MyRow = 1 To 6
   
5.     For i = 1 To 5
   
6.         If Cells(MyRow, "h") = Cells(i, 1) Then
   
7.             MyStr = MyStr & "," & Cells(i, 2)
   
8.         End If
   
9.     Next
   
10.     Cells(MyRow, "i") = Mid(MyStr, 2, 99)
    
11.     MyStr = ""
    
12. Next
    
13. End Sub

复制代码

彼德仔

pureshadow 发表于 2017-5-27 14:46

2016的函数呀。

周义坤

1. Sub ek_sky()
   
2.   Dim dic As Object
   
3.   Dim arr As Variant, brr As Variant
   
4.   Dim i As Integer
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.       arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
   
7.       brr = Range("H1:I" & Cells(Rows.Count, "H").End(xlUp).Row)
   
8.          For i = 1 To UBound(arr)
   
9.               dic(arr(i, 1)) = dic(arr(i, 1)) & "," & arr(i, 2)
   
10.          Next i
    
11.          For i = 1 To UBound(brr)
    
12.            brr(i, 2) = Mid(dic(brr(i, 1)), 2)
    
13.          Next i
    
14. Range("H1").Resize(UBound(brr), 2) = brr
    
15. End Sub
    

复制代码