提取两列中相同的内容到第三列

yshcy

请教代码，谢谢。

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr)
        brr = Split("," & Replace(arr(j, 1), "，", ","), ",")
        str1 = ""
        str2 = "," & Replace(arr(j, 2), "，", ",") & ","
        For i = 1 To UBound(brr)
            If InStr(str2, "," & brr(i) & ",") > 0 Then
                str1 = str1 & "," & brr(i)
            End If
        Next i
        If Len(str1) > 0 Then arr(j, 3) = Mid(str1, 2)
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

模拟结果供参考

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, strReplace$, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Range("A1", Cells(Rows.Count, "B").End(xlUp)).Value
    ReDim cr(1 To UBound(ar), 0)
    cr(1, 0) = "想要的结果"
    For i = 2 To UBound(ar)
        strReplace = Replace(ar(i, 1), "，", ",")
        br = Split(strReplace, ",")
        For j = 0 To UBound(br)
            dic(br(j)) = Empty
        Next j
        strReplace = Replace(ar(i, 2), "，", ",")
        br = Split(strReplace, ",")
        For j = 0 To UBound(br)
            If dic.exists(br(j)) Then cr(i, 0) = cr(i, 0) & "，" & br(j)
        Next j
       cr(i, 0) = "'" & Mid(cr(i, 0), 2)
    Next i
   
    [E1].Resize(UBound(cr)) = cr
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

请参考。。。

swl4561255

1. Sub test()
   
2. ar = [A1].End(4).Row
   
3. arr = Range("A2:A" & ar)
   
4. brr = Range("B2:B" & ar)
   
5. Dim crr(1 To 100, 1 To 1)
   
6. For i = 1 To ar - 1
   
7.     myst = ""
   
8.     br = Split(Replace(brr(i, 1), ",", "，"), "，")
   
9.         For j = 0 To UBound(br)
   
10.             If InStr("，" & Replace(arr(i, 1), ",", "，") & "，", "，" & br(j) & "，") Then
    
11.                 myst = myst & "," & br(j)
    
12.             End If
    
13.         Next
    
14.     crr(i, 1) = Mid(myst, 2)
    
15. Next
    
16. [C2].Resize(ar - 1, 1) = crr
    
17. End Sub

复制代码