Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æ«e:

¤U¸ü (126.73 KB)

2023-6-15 15:10

°õ¦æµ²ªG:

¤U¸ü (136.08 KB)

2023-6-15 15:11

Option Explicit
Sub TEST()
Dim Brr, Va&, Vb&, Z, Q, i&, Ra&, Rb&, M&, Ta$, Tb$
[E7:F65536,I2:J65536].ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([A1].CurrentRegion, [A:B])
For i = 1 To UBound(Brr)
   Ta = Brr(i, 1): Tb = Brr(i, 2): Brr(i, 1) = "": Brr(i, 2) = ""
   If Ta = "" Then GoTo i01 Else Va = Z(Ta)
   If Va = 1 Then
      Ra = Ra + 1
      Brr(Ra, 1) = Ta
      M = IIf(M < Ra, Ra, M)
      Else:
         Z(Ta) = 1
   End If
i01: If Tb = "" Then GoTo i02 Else Vb = Z("|" & Tb)
   If Vb = 1 Then
      Rb = Rb + 1
      Brr(Rb, 2) = Tb
      M = IIf(M < Rb, Rb, M)
      Else
         Z("|" & Tb) = 1
   End If
i02: Next
If M > 0 Then [E7].Resize(M, 2) = Brr
ReDim Brr(1 To UBound(Brr), 1 To 2)
Ra = 0: Rb = 0: M = 0
For Each Q In Z.KEYS
   If InStr(Q, "|") = 0 Then
      If Z.Exists("|" & Q) = Empty Then
         Rb = Rb + 1
         Brr(Rb, 2) = Q
      End If
      ElseIf Z.Exists(Mid(Q, 2)) = Empty Then
         Ra = Ra + 1
         Brr(Ra, 1) = Mid(Q, 2)
   End If
   If M < Ra Then M = Ra
   If M < Rb Then M = Rb
Next
If M > 0 Then [I2].Resize(M, 2) = Brr
Set Z = Nothing: Erase Brr
End Sub