·Q§ä¥X»P«e¤@¦C­«½Æªº¼Æ¦r

f00l01

¦U¦ì¥ý¶i¦n¡A

½Ð°Ý¬O§_¯à¦C¥X¨C¤@¦C»P¤W¤@¦C¬Û¤ñ¦³­«½Æªº¼Æ¦r¡H

·PÁ¤j®aªºÀ°¦£~

Andy2483

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

°õ¦æµ²ªG:

¤U¸ü (81.49 KB)

2023-5-29 14:35

Option Explicit
Sub TEST()
Dim Brr, i&, j%, A$, Q$, TT$, T$
'¡ô«Å§iÅܼÆ
Brr = Range([M1], [A65536].End(xlUp))
'¡ô¥OBrrÅܼƬO ¤Gºû°}¦C,¥HA~MÄæÀx¦s®æ­È±a¤J°}¦C¤¤
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°éi
   For j = 1 To UBound(Brr, 2)
   '¡ô³]¶¶°j°éj
      T = Brr(i, j)
      '¡ô¥OTÅܼƬO °j°éBrr°}¦C­È
      If InStr(A, "/" & T & "/") Then TT = TT & "," & T
      '¡ô¦pªGAÅÜ¼Æ ¥]§t¤F¥H(TÅܼƦb«e«á¥]§¨"/"ªº·s¦r¦ê)??
      '¡ô¥OTÅܼƯǤJTTÅܼƫá¤è,¥H³rÂI¹j¶},¦¨¬°·s¦r¦ê
      '(·íi=1®É,A¬Oªì©l­È"",©Ò¥H±ø¥ó³£¤£·|¦¨¥ß)
      Q = Q & "/" & T & "/"
      '¡ô¥OQÅܼƦ¬¶°¸Ó°j°éªº°}¦C­È,°µ¬°¤U¤@°j°éªºAÅܼÆ
   Next j
   Brr(i, 1) = Mid(TT, 2): TT = "": A = Q: Q = ""
   '¡ô¥OBrr°}¦C²Ä1Äæ¼g¤J²Å¦X±ø¥óªº¼Æ¦r
Next i
[P1].Resize(UBound(Brr)) = Brr
'¡ô¥OBrr°}¦C­È±q[P1]¶}©l¼g¤JÀx¦s®æ¸Ì,¶W¹L¦¹½d³òªº°}¦C­È©¿²¤
End Sub

­ã´£³¡ªL

¦^´_ 14# samwang


12F

Åý¦r¨åªºkey§¨±a i ­È
·í i=1 ®É
±N xd(T & "/" & 1)=1 ¥[¤J¦r¨å,
¦P®ÉÀˬd xd(T & "/" &  0) ¬O§_¦b¦r¨å¤¤, ¦]¬O²Ä1¦æ, ©Ò¥H³£¬°"ªÅ­È",

·í i=2 ®É
±N xd(T & "/" & 2)=1 ¥[¤J¦r¨å,
¦P®ÉÀˬd xd(T & "/" &  1) ¬O§_¦b¦r¨å¤¤, ¦]¬O²Ä2¦æ, ¥u­n¦r¨åkey±a1ªº, §Y¬O¤W¤U¦æ¬Û¦P

Ãþ±À~~
³o¤èªkÅý©Ò¦³¼Æ¦r³£¦]¦æ¸¹¤£¦P¦Ó¥þ³¡¯Ç¤J¦r¨å, ¦U¦Û¦¨¬°¿W¥ßªºkey­È,
¯ÊÂI: ¦r¨å·|©ñ¤Ó¦h¸ê®Æ

samwang

¦^´_ 13# ­ã´£³¡ªL

¦r¨åÀH¨úÀH®ø, ´î¤Ö¦û¥Î¸ê·½~~
>> ·PÁ­ã¤j¤À¨É¡A¼g±oºë²¤F¡Aµo²{¦Û¤v¼gªº¤Ó½ÆÂø¡A#12¼Óªº¼gªk²Ä1¦¸¬Ý¹L¡A
¯uªº¤£¦n²z¸Ñ¡A­n¦n¦nªº¬ã¨s¾Ç²ß¤@¤U¡AÁÂÁ¡C

­ã´£³¡ªL

¦r¨åÀH¨úÀH®ø, ´î¤Ö¦û¥Î¸ê·½~~

Sub TEST_A02()
Dim Arr, Brr, xD, i&, j%, TT$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([m1], [a65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 0)
For i = 2 To UBound(Arr)
    For j = 1 To UBound(Arr, 2)
        xD(Arr(i - 1, j) & "") = 1
    Next j
    For j = 1 To UBound(Arr, 2)
        If xD(Arr(i, j) & "") = 1 Then TT = TT & "," & Arr(i, j)
    Next j
    Brr(i, 0) = Mid(TT, 2): TT = "": xD.RemoveAll
Next i
[p1].Resize(UBound(Brr)) = Brr
End Sub


.==============================

­ã´£³¡ªL

PÄæ³]¬°¤å¦r®æ¦¡~~

Sub TEST_A01()
Dim Arr, xD, i&, j%, T$, TT$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([m1], [a65536].End(xlUp))
For i = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
    T = Arr(i, j): xD(T & "/" & i) = 1
    If xD(T & "/" & i - 1) = 1 Then TT = TT & "," & T
Next j
    Arr(i, 1) = Mid(TT, 2): TT = ""
Next i
[p1].Resize(UBound(Arr)) = Arr
End Sub


'==============================

f00l01

¦nªº¡A§Ú¦A´ú¸Õ¬Ý¬Ý¡AÁÂÁ¤j¤j

samwang

¦^´_ 1# f00l01


¤ñ¹ï«áµ²ªGÅã¥Ü¦b¦P¤@®æÀx¦s®æ¡A½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C
Sub µ²ªGÅã¥Ü¦P¤@®æ()
Dim Arr, Ar(), xD, xD2, T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
ReDim Ar(1 To UBound(Arr), 0)
For i = 1 To UBound(Arr)
    For j = 1 To UBound(Arr, 2)
        T = Arr(i, j)
        If i = 1 Then xD(T & "") = T: GoTo 99
        If C = 0 Then
            M = xD(T & ""): xD2(T & "") = T
            If M > 0 Then Ar(i, 0) = Ar(i, 0) & "," & xD(T & "")
        Else
            M = xD2(T & ""): xD(T & "") = T
            If M > 0 Then Ar(i, 0) = Ar(i, 0) & "," & xD2(T & "")
        End If
99: Next
    If i > 1 Then
        If C = 0 Then
            Ar(i, 0) = Mid(Ar(i, 0), 2): C = 1: Set xD = Nothing
            Set xD = CreateObject("Scripting.Dictionary")
        Else
            Ar(i, 0) = Mid(Ar(i, 0), 2): C = 0: Set xD2 = Nothing
            Set xD2 = CreateObject("Scripting.Dictionary")
        End If
    End If
Next
Range("N1").Resize(UBound(Arr)) = Ar
End Sub

samwang

²¤Æ¤@¤U#8¼Óµ{¦¡¡A¤£¦n·N«ä¡A«á¾Ç«ä¼{¤£°÷²Ó¤ß¡A¤@ª½¦A­×§ï²¤Æ¡A½Ð¦A´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C
Sub test3()
Dim Arr, xD, xD2, Ar(), T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
For i = 1 To UBound(Arr)
    ReDim Ar(1 To 1, 1 To UBound(Arr, 2))
    For j = 1 To UBound(Arr, 2)
        T = Arr(i, j)
        If i = 1 Then xD(T & "") = T: GoTo 99
        If C = 0 Then
            M = xD(T & ""): xD2(T & "") = T
            If M > 0 Then N = N + 1: Ar(1, N) = xD(T & "")
        Else
            M = xD2(T & ""): xD(T & "") = T
            If M > 0 Then N = N + 1: Ar(1, N) = xD2(T & "")
        End If
99: Next
    If i > 1 Then
        If C = 0 Then
            Cells(i, 15).Resize(1, N) = Ar
            C = 1: Erase Ar: Set xD = Nothing: N = 0
            Set xD = CreateObject("Scripting.Dictionary")
        Else
            Cells(i, 15).Resize(1, N) = Ar
            C = 0: Erase Ar: Set xD2 = Nothing: N = 0
            Set xD2 = CreateObject("Scripting.Dictionary")
        End If
    End If
Next
End Sub

samwang

²¤Æ¤@¤U#7¼Óµ{¦¡¡A½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C
¼g±o¤£¦n¡A¤£ª¾¨ä¥L¤j¤j¦³µL¨ä¥L¼gªk¥i¤À¨É¡A·PÁ¡C

Sub test2()
Dim Arr, xD, xD2, Ar(), T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
For i = 1 To UBound(Arr)
    ReDim Ar(1 To 1, 1 To UBound(Arr, 2))
    For j = 1 To UBound(Arr, 2)
        T = Arr(i, j)
        If i = 1 Then xD(T & "") = T: GoTo 99
        If C = 0 Then
            M = xD(T & "")
            If M > 0 Then N = N + 1: Ar(1, N) = xD(T & "")
            xD(T & "") = T: xD2(T & "") = T
        Else
            M = xD2(T & "")
            If M > 0 Then N = N + 1: Ar(1, N) = xD2(T & "")
            xD(T & "") = T: xD2(T & "") = T
        End If
99: Next
    If i > 1 Then
        If C = 0 Then
            Cells(i, 15).Resize(1, N) = Ar
            C = 1: Erase Ar: Set xD = Nothing: N = 0
            Set xD = CreateObject("Scripting.Dictionary")
        Else
            Cells(i, 15).Resize(1, N) = Ar
            C = 0: Erase Ar: Set xD2 = Nothing: N = 0
            Set xD2 = CreateObject("Scripting.Dictionary")
        End If
    End If
Next
End Sub