比较提取数据

SCWYZJ

求助：怎样用函数或vba按指定条件比较并提取相同和不同数据到新表（见附件）。请老师帮忙看看！谢谢！

一把小刀闯天下

'相同的未做去重

Option Explicit

Sub test()
  Dim i, j, k, dic, arr, sht, crr, t
  Set dic = CreateObject("scripting.dictionary")
  sht = Split("表一 表二 不同 相同")
  For i = 0 To 1
    arr = Sheets(sht(i)).[a1].CurrentRegion
    Call setdatatodic(arr, dic)
  Next
  ReDim brr(1 To 10 ^ 4, 1 To UBound(arr, 2)), m(2 To 3)
  crr = brr
  For i = 0 To 1
    arr = Sheets(sht(i)).[a1].CurrentRegion
    For j = 2 To UBound(arr, 1)
      t = arr(j, 2)
      For k = 3 To UBound(arr, 2): t = t & arr(j, k): Next
      If dic(t) = 1 Then '不同
        m(2) = m(2) + 1
        For k = 2 To UBound(arr, 2): brr(m(2), k) = arr(j, k): Next
      Else
        m(3) = m(3) + 1
        For k = 2 To UBound(arr, 2): crr(m(3), k) = arr(j, k): Next
      End If
  Next j, i
  Call putdatatosht(sht(2), m(2), brr)
  Call putdatatosht(sht(3), m(3), crr)
End Sub

Function putdatatosht(s, n, arr)
  With Sheets(s).[a2]
    .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(arr, 2)) = arr
  End With
End Function

Function setdatatodic(arr, dic)
  Dim i, j, t
  For i = 2 To UBound(arr, 1)
    t = arr(i, 2)
    For j = 3 To UBound(arr, 2): t = t & arr(i, j): Next
    dic(t) = dic(t) + 1
  Next
End Function

LMY123

字典法，同薄双表比对

SCWYZJ

我是菜鸟，不是很懂vba,但我试了下，基本符合要求，谢谢你

excelvlookup

这个可以完全达到你的要求。加了一个推论，不同是取重复的全部