提取差异数

为工作

提取差异数，请用VBA

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, xD, i&, n&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range("d1").CurrentRegion
For i = 2 To UBound(Arr): xD(Arr(i, 2) & "") = 1: Next
For i = 2 To UBound(Arr)
    If xD(Arr(i, 1) & "") = 1 Then GoTo 99
    n = n + 1: Arr(n, 1) = Arr(i, 1)
99: Next
[h2].Resize(n, 1) = Arr
End Sub

为工作

sam-wang 发表于 2022-6-20 18:08
請測試看看，謝謝
Sub test()
Dim Arr, xD, i&, n&

谢谢

hasyh2008

Sub tt()
  Dim Ar, Br, Cr(), X%, K%, Rg1, Rg2
  With ActiveSheet
   Set Rg1 = .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
   Set Rg2 = .Range("E2:E" & .Cells(Rows.Count, 5).End(xlUp).Row)
   Ar = .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)
   Br = .Range("E2:E" & .Cells(Rows.Count, 5).End(xlUp).Row)
    ReDim Cr(1 To 1000, 1 To 2)
    For X = 1 To Rg1.Rows.Count
      If Application.CountIf(Rg2, Ar(X, 1)) < 1 Then
        K = K + 1
        Cr(K, 1) = Ar(X, 1)
      End If
    Next X
    K = 0
    For X = 1 To Rg2.Rows.Count
      If Application.CountIf(Rg1, Br(X, 1)) = 0 Then
        K = K + 1
        Cr(K, 2) = Br(X, 1)
      End If
    Next X
    .Cells(2, 8).Resize(1000, 2) = Cr
  End With
  Set Rg1 = Nothing
  Set Rg2 = Nothing
End Sub