loyyee

¦^´_ 10# dechiuan999

±z¦n µ{¦¡¥i¥H¥Î¤F!
¦ý¦pªG¸ê®Æ§ïÅܦpªþÀÉ¥B¤W¤dµ§·|¥X²{¿ù»~¡A³Ò¾r±zÀ°¦£¬Ý¬Ý¡C

¼Æ­È¤ñ¹ï2.rar (65.37 KB)

¤U¸ü¦¸¼Æ: 16

2011-10-9 16:02

Hsieh

¦^´_ 11# loyyee
¨Ã«D¸ê®Æµ§¼Æ°ÝÃD
¬O¦pªG¨S¦³©M±ø¥óªº¸ê®Æ´N·|³y¦¨Resize¥X¿ù

1. Sub Ex()
   
2. Dim Ay(), Ay1()
   
3. Set d = CreateObject("Scripting.dictionary")
   
4. Set d1 = CreateObject("Scripting.dictionary")
   
5. [E6].CurrentRegion.Offset(1, 0) = ""
   
6. [I1].CurrentRegion.Offset(1, 0) = ""
   
7. 
   
8. ar1 = [A1].CurrentRegion.Columns(1).Value
   
9. ar2 = [A1].CurrentRegion.Columns(2).Value
   
10. ar = Array(ar1, ar2)
    
11. For i = 0 To 1
    
12. For Each a In ar(i)
    
13.    Select Case i
    
14.    Case 0
    
15.    If a <> "" Then d(a) = d(a) + 1
    
16.    Case 1
    
17.    If a <> "" Then d1(a) = d1(a) + 1
    
18.    End Select
    
19. Next
    
20. Next
    
21. dic = Array(d, d1)
    
22. For i = 0 To 1
    
23. For Each ky In dic(i).keys
    
24. p = IIf(i = 0, 1, 0)
    
25.    If dic(p).exists(ky) = False Then
    
26.    ReDim Preserve Ay(s)
    
27.    Ay(s) = ky
    
28.    s = s + 1
    
29.    End If
    
30.    If dic(i)(ky) > 1 Then
    
31.    ReDim Preserve Ay1(k)
    
32.    Ay1(k) = ky
    
33.    k = k + 1
    
34.    End If
    
35. Next
    
36. If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
    
37. If k > 0 Then Cells(7, 5 + i).Resize(k, 1) = Application.Transpose(Ay1): k = 0: Erase Ay1
    
38. Next
    
39. End Sub

½Æ»s¥N½X

loyyee

¦^´_ 12# Hsieh

¥i¥H¥Î¤F¡AHsieh·PÁ±z«üÂI!

fyo00241

·PÁ¦U¤j¤jªº¤À¨É,,ÁöµM¤£¯à¤U¸üªþ¥ó¤]¾Ç²ß¤F

loyyee

¦^´_ 12# Hsieh

If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay ­n§ï¦¨
If s > 0 Then Cells(2, 10 - i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
   
¤í¯Ê¼Æ­ÈÄæ¦ì¤~·|¹ïÀ³¨ì¡C

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