Andy2483

¦^´_ 1# aassddff736


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

Option Explicit
Sub TEST1()
Dim Arr, Brr, Crr, K, Z, N&, i&, j%, R&, Ta$, Tb$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Arr = Range([a¸ê®Æ!F1], [a¸ê®Æ!A65536].End(3)): Brr = Range([b¸ê®Æ!F1], [b¸ê®Æ!A65536].End(3))
ReDim Crr(1 To (UBound(Arr) + UBound(Brr)), 1 To 2)
For i = 2 To UBound(Arr)
   Ta = Trim(Arr(i, 1)): If Ta <> "" Then Z(Ta) = Z(Ta) + 1: Z(Ta & "/Ra") = i: Arr(i, 6) = "": R = R + 1: Crr(R, 1) = Ta: Crr(R, 2) = 1
Next
For i = 2 To UBound(Brr)
   Tb = Trim(Brr(i, 1)): If Z(Tb) = 0 Then R = R + 1: Crr(R, 1) = Tb Else Crr(Z(Tb & "/Ra") - 1, 2) = Crr(Z(Tb & "/Ra") - 1, 2) + 1
   If Tb <> "" Then Z(Tb) = Z(Tb) + 1: Z(Tb & "/Rb") = i: Brr(i, 6) = ""
Next
For Each K In Z.KEYS
   If InStr(K, "/") = 0 And Z(K) = 2 Then N = N + 1: Arr(Z(K & "/Ra"), 6) = N: Brr(Z(K & "/Rb"), 6) = N
Next
Application.Goto [¤ñ¹ïµ²ªG!A1]
ActiveSheet.UsedRange.Clear: [A:B,H:H].NumberFormatLocal = "@"
With [A2].Resize(R, 2): .Value = Crr: .Sort KEY1:=.Item(2), Order1:=2, Header:=1: [A1] = "NUMBER": End With
With [B1].Resize(UBound(Arr), 6): .Value = Arr: .Sort KEY1:=.Item(6), Order1:=1, Header:=1: Arr = .Value: End With
With [H1].Resize(UBound(Brr), 6): .Value = Brr: .Sort KEY1:=.Item(6), Order1:=1, Header:=1: Brr = .Value: End With
[G:G,M:M].ClearContents: Set xR = ActiveSheet.UsedRange.Offset(N + 1, 1)
For i = 2 To N + 1
   For j = 3 To 6: Set xR = IIf(Val(Arr(i, j)) <> Val(Brr(i, j)), Union(xR, Cells(i, j + 1)), xR): Next
Next
Intersect(Union(xR, xR.Offset(, 6)), ActiveSheet.UsedRange).Font.ColorIndex = 3
With Sheets("¯d¤U¬Û¦P")
   .UsedRange.Clear: ActiveSheet.UsedRange.Copy .[A1]: .Range(Intersect(xR, ActiveSheet.UsedRange).Address).EntireRow.Delete
End With
With Sheets("¯d¤U®t²§")
   .UsedRange.Clear: Intersect(Union([A1], xR), ActiveSheet.UsedRange).EntireRow.Copy .[A1]
End With
End Sub