用VB匹配A列和B列的共同数据并输出在C列

强歌

要求：用VB代码把A列和B列数据进行匹配，并把A列和B列都有的数据依次显示在C列

LMY123

双列比对，提取交集，或字典法，提取重复次数大于1次的

强歌

请帮我设计一段VB代码试试，谢谢

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, n, t
  arr = [a1].CurrentRegion
  ReDim brr(1 To 2 * UBound(arr, 1) + 1, 1 To 1)
  For j = 1 To UBound(arr, 2)
    For i = 2 To UBound(arr, 1)
      If Len(arr(i, j)) = 0 Then Exit For
      m = m + 1: brr(m, 1) = arr(i, j)
  Next i, j
  For i = 1 To m - 1
    For j = i To m
      If brr(i, 1) > brr(j, 1) Then
        t = brr(i, 1): brr(i, 1) = brr(j, 1): brr(j, 1) = t
      End If
  Next j, i
  For i = 1 To m
    For j = i To m
      If brr(j, 1) <> brr(j + 1, 1) Then
        If j > i Then n = n + 1: brr(n, 1) = brr(i, 1)
        i = j: Exit For
      End If
  Next j, i
  With [c2]
    .Resize(Rows.Count - 1).ClearContents
    If n > 0 Then .Resize(n) = brr
  End With
End Sub

cjc209

Sub 一组数据字典判断重复情况()
    Dim arr2()
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = [a2:a30]
        For i = 1 To 29
            d(arr(i, 1)) = ""
        Next
        arr1 = [b2:b12]
        For i = 1 To 11
            d1(arr1(i, 1)) = ""
        Next
            For Each Rng In d.keys
                If d1.exists(Rng) Then
                m = m + 1
                ReDim Preserve arr2(1 To m)
                arr2(m) = Rng
            End If
        Next
    [c1] = "共有数据"
    [c2].Resize(m) = Application.Transpose(arr2)
End Sub

sdc3211772

Sub test()
Dim d As Object, arr, arr2, i%, j%
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2", Cells(Rows.Count, 1).End(xlUp))
    arr2 = Range("b2", Cells(Rows.Count, 2).End(xlUp))
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr2)
            If arr(i, 1) = arr2(j, 1) Then d(arr(i, 1)) = ""
        Next
    Next
    Range("c:c").ClearContents
    Cells(1, 3) = "两列共有数据"
    Cells(2, 3).Resize(d.Count) = Application.Transpose(d.keys)
End Sub

lrh788

sdc3211772 发表于 2018-12-19 22:14
Sub test()
Dim d As Object, arr, arr2, i%, j%
    Set d = CreateObject("scripting.dictionary")

老师，如果取不同的数据到c列的代码应怎么写呢？

sdc3211772

lrh788 发表于 2018-12-19 22:42
老师，如果取不同的数据到c列的代码应怎么写呢？

Sub test123()
Dim d As Object, arr, arr2, i%, j%, brr(), m%, n%
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(arr, 2)
        For j = 1 To UBound(arr)
            If arr(j, i) <> "" Then
                m = m + 1
                ReDim Preserve brr(1 To m)
                brr(m) = arr(j, i)
            End If
        Next
    Next
    For i = 1 To UBound(brr)
        n = 0
        For j = 1 To UBound(brr)
            If brr(i) = brr(j) Then n = n + 1
        Next
        If n = 1 Then d(brr(i)) = ""
    Next
    Range("c:c").ClearContents
    Cells(1, 3) = "两列共有数据"
    Cells(2, 3).Resize(d.Count) = Application.Transpose(d.keys)
    End Sub

仲夏之雪

用字典，很快的

lrh788

sdc3211772 发表于 2018-12-19 23:39
Sub test123()
Dim d As Object, arr, arr2, i%, j%, brr(), m%, n%
    Set d = CreateObject("scrip ...

谢谢老师！我还想请教下，如果是两表多列同时比较，把不同的数据分别提取到第三表的不同位置，又该怎么写代码？