Office中国论坛/Access中国论坛
标题:
一对多匹配求助代码的写法
[打印本页]
作者:
彼德仔
时间:
2017-5-26 21:15
标题:
一对多匹配求助代码的写法
本帖最后由 彼德仔 于 2017-5-26 21:38 编辑
求助用vba 的方法
作者:
roych
时间:
2017-5-27 14:11
请参考:
http://www.office-cn.net/thread-96091-1-1.html
作者:
pureshadow
时间:
2017-5-27 14:46
=TEXTJOIN(",",,IF(A$1:A$5=H1,B$1:B$5,""))
复制代码
作者:
pureshadow
时间:
2017-5-27 14:52
代码版:
Sub Sample()
Dim MyRow As Long, i As Long
Dim MyStr As String
For MyRow = 1 To 6
For i = 1 To 5
If Cells(MyRow, "h") = Cells(i, 1) Then
MyStr = MyStr & "," & Cells(i, 2)
End If
Next
Cells(MyRow, "i") = Mid(MyStr, 2, 99)
MyStr = ""
Next
End Sub
复制代码
作者:
彼德仔
时间:
2017-5-27 16:38
pureshadow 发表于 2017-5-27 14:46
2016的函数呀。
作者:
周义坤
时间:
2017-5-29 11:19
Sub ek_sky()
Dim dic As Object
Dim arr As Variant, brr As Variant
Dim i As Integer
Set dic = CreateObject("scripting.dictionary")
arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
brr = Range("H1:I" & Cells(Rows.Count, "H").End(xlUp).Row)
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) & "," & arr(i, 2)
Next i
For i = 1 To UBound(brr)
brr(i, 2) = Mid(dic(brr(i, 1)), 2)
Next i
Range("H1").Resize(UBound(brr), 2) = brr
End Sub
复制代码
作者:
周义坤
时间:
2017-5-29 19:21
Function testjoin(a As Range, b As String)
Dim c As Variant, i As Long, t As String
c = a
For i = 1 To UBound(c)
If c(i, 1) = b Then
t = t & "," & c(i, 2)
End If
Next i
testjoin = Mid(t, 2)
End Function
复制代码
欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)
Powered by Discuz! X3.3