VBA用两种方法 找出两列相同两列不同

laoau128

VBA用两种方法  找出两列相同两列不同

zhshspark

什么意思？你要做什么？

laoau128

zhshspark 发表于 2018-12-6 22:55
什么意思？你要做什么？

用数组和字典两种方法，
从AB两列比较找出相同项保存D列
从AB两列比较找出不相同项保存E列

一把小刀闯天下

Option Explicit

Sub 字典()
  Dim i, j, arr, t
  arr = [a1].CurrentRegion
  ReDim dic(1 To UBound(arr, 2)), brr(1 To UBound(arr, 1), 1 To 2)
  ReDim m(1 To UBound(brr, 2))
  For i = 1 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      dic(j)(arr(i, j)) = vbNullString
  Next j, i
  For Each t In dic(1).keys
    If dic(2).exists(t) Then
      m(1) = m(1) + 1: brr(m(1), 1) = t: dic(2).Remove (t)
    Else
      m(2) = m(2) + 1: brr(m(2), 2) = t
    End If
  Next
  If dic(2).Count > 0 Then
    t = dic(2).keys
    For i = 0 To UBound(t): m(2) = m(2) + 1: brr(m(2), 2) = t(0): Next
  End If
  [d2].Resize(UBound(brr, 1), 2) = brr
End Sub

Sub 数组()
  Dim i, j, k, arr, t, m(1 To 2), p
  arr = Range("a1:b" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  ReDim brr(1 To UBound(arr, 1), 1 To 2)
  Call dsort(arr, 1): Call dsort(arr, 2)
  p = 1
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 1)) Then
      For j = p To UBound(arr, 1) - 1
        If arr(i, 1) = arr(j, 2) Then
          m(1) = m(1) + 1: brr(m(1), 1) = arr(i, 1)
          For k = i To UBound(arr, 1) - 1
            If arr(k + 1, 1) <> arr(k, 1) Then
              arr(k, 1) = vbNullString: i = k: Exit For
            Else
              arr(k, 1) = vbNullString
            End If
          Next
          For k = j To UBound(arr, 1) - 1
            If arr(k + 1, 2) <> arr(k, 2) Then
              arr(k, 2) = vbNullString: p = k + 1: Exit For
            Else
              arr(k, 2) = vbNullString
            End If
          Next
          Exit For
        End If
      Next
      If j = UBound(arr, 1) Then m(2) = m(2) + 1: brr(m(2), 2) = arr(i, 1)
    End If
  Next
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 2)) Then m(2) = m(2) + 1: brr(m(2), 2) = arr(i, 2)
  Next
  [g2].Resize(UBound(brr, 1), 2) = brr
End Sub

Function dsort(arr, n)
  Dim i, j, t
  For i = 1 To UBound(arr, 1) - 2
    For j = i + 1 To UBound(arr) - 1
      If arr(i, n) > arr(j, n) Then
        t = arr(i, n): arr(i, n) = arr(j, n): arr(j, n) = t
      End If
  Next j, i
End Function

laoau128

一把小刀闯天下 发表于 2018-12-7 13:39
Option Explicit

Sub 字典()

果然是高手

不过程序看不懂，暂时先收下慢慢再研究