[µo°Ý] ½Ð°Ý¦p¦ó¤@个±ø¥ó¤Ç°t¦h个µ²ªG(¥h­«½Æ)

hycn

½Ð°Ý¤@个条¥ó¤Ç°t¦h个结ªG¨Ã¥h­«½Æ
³o VBA Function ¨ç¼Æ­n¦p¦ó­×§ï
¦]¬°EÄæ³æ¤¸®æ±ø¥ó¤Ç°t¬O§Æ±æ¥h­«½Æ¨Ã¦³" , "²Å¸¹¹j¶}

¦b¦¹¥ý¨¥Á ~

¤@­Ó±ø¥ó¤Ç°t¦h­Óµ²ªG(¥h­«½Æ).rar (10.65 KB)

¤U¸ü¦¸¼Æ: 19

2020-11-8 09:54

hcm19522

https://blog.xuite.net/hcm19522/twblog/589452662

samwang

¦^´_ 1# hycn


    Sub test()
    Dim arr, ´Ñ½L(1 To 2000, 1 To 2), i%
    Dim d As Object, d1 As Object
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Range("b1", [a65536].End(xlUp))

    For i = 1 To UBound(arr)
        xR = arr(i, 1) & arr(i, 2)
        If d.Exists(arr(i, 1)) Then
            If d1.Exists(xR) Then GoTo 100
            ¦C = d(arr(i, 1))
            ´Ñ½L(¦C, 2) = ´Ñ½L(¦C, 2) & "," & arr(i, 2)
        Else
            k = k + 1
            d(arr(i, 1)) = k
            ´Ñ½L(k, 1) = arr(i, 1)
            ´Ñ½L(k, 2) = arr(i, 2)
        End If
        d1(xR) = arr(i, 1) & arr(i, 2)
100:    Next
    Range("D1").Resize(k, 2) = ´Ñ½L
End Sub

­ã´£³¡ªL

¦^´_ 1# hycn

Function abc(a As Range, b As Range, c$) As String
Dim Ta$, Tb$, TT$
If a.Count <> b.Count Then abc = "error": Exit Function
If c = "" Then Exit Function
For i = 1 To a.Count
    Ta = a(i, 1):  Tb = b(i, 1)
    If Ta <> c Or Tb = "" Then GoTo 101
    If InStr("," & TT & ",", "," & Tb & ",") = 0 Then TT = TT & "," & Tb  '¤ñ¹ïb¤å¦r¬O§_¤w¦s¦b¤_TT¦r¦ê¤¤
101: Next
abc = Mid(TT, 2)
End Function

Andy2483

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


    ÁÂÁ½׾Â,ÁÂÁ«e½ú
«á¾ÇÂǦ¹©«¾Ç²ß«e½úªº¤è®×,¤è®×¾Ç²ß¤ß±oµù¸Ñ¦p¤U,½Ð«e½ú¦A«ü¾É

°õ¦æµ²ªG:

¤U¸ü (45.06 KB)

2023-6-6 09:50

Function abc(a As Range, b As Range, c$) As String
'¡ô¦Û­q¨ç¼Æabc().«Å§iÅܼÆ:(a,b)¬OÀx¦s®æÅܼÆ,c¬O¦r¦êÅܼÆ,¨ç¼Æ­È¬O¦r¦ê
Dim Ta$, Tb$, TT$
'¡ô«Å§iÅܼÆ!(Ta,Tb,TT)¬O¦r¦êÅܼÆ
If a.Count <> b.Count Then abc = "error": Exit Function
'¡ô¦pªGaÅܼÆ(Àx¦s®æ)¼Æ¶q»P bÅܼÆ(Àx¦s®æ)¼Æ¶q¤£¦P?
'´N¥Oabc¨ç¼Æ¦^¶Ç"error"¦r¦ê,µM«áµ²§ôµ{¦¡°õ¦æ
If c = "" Then Exit Function
'¡ô¦pªGcÅܼƬOªÅ¦r¤¸?´Nµ²§ôµ{¦¡°õ¦æ
For i = 1 To a.Count
'¡ô³]¶¶°j°é!±q1¨ì aÅܼÆ(Àx¦s®æ)¼Æ¶q
    Ta = a(i, 1):  Tb = b(i, 1)
    '¡ô¥OTaÅܼƬOaÅܼÆ(½d³òÀx¦s®æ)¸ÌªºiÅܼƦC,²Ä1ÄæÀx¦s®æ­È,
    '¡ô¥OTbÅܼƬObÅܼÆ(½d³òÀx¦s®æ)¸ÌªºiÅܼƦC,²Ä1ÄæÀx¦s®æ­È
    If Ta <> c Or Tb = "" Then GoTo 101
    '¡ô¦pªGTaÅܼƤ£µ¥©óCÅܼÆ,©ÎTbÅܼƬOªÅ¦r¤¸,´N¸õ¨ì¼Ð¥Ü101¦ì¸mÄ~Äò°õ¦æ
    If InStr("," & TT & ",", "," & Tb & ",") = 0 Then TT = TT & "," & Tb
    '¦pªG¤ñ¹ïTbÅܼƤå¦r¨S¦³¦s¦b¤_TTÅܼƦr¦ê¤¤?
    '´N¥OTbÅܼƥH³r¸¹¹j¶}¥[¦bTTÅܼƫá¤è
101: Next
abc = Mid(TT, 2)
'¡ô¥Oabc¨ç¼Æ¦^¶ÇTTÅܼÆÂ^¨ú²Ä2¦r«áªº©Ò¦³¦r¦ê(¦]¬°³Ì«e­±¬O³r¸¹,¤£¨ú)
End Function

Andy2483

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


Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, T1$, T2$
'¡ô«Å§iÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OYÅܼƬO ¦r¨å
Brr = Range([B2], [A65536].End(3))
'¡ô¥OBrrÅܼƬO¤Gºû°}¦C,¥H[B2]¨ìAÄæ³Ì«á¤@¦³¤º®eªºÀx¦s®æ­È±a¤J
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é
   T1 = Brr(i, 1): T2 = Brr(i, 2)
   '¡ô¥OÅܼƸˤJ°j°é°}¦C­È,¥i¥H©w¸q­Èªº«¬ºA,¤]¥iÁYµuµ{¦¡½X
   If T1 = "" Or T2 = "" Then GoTo i01
   '¡ô¦pªGT1ÅܼƬOªÅªº©Î T1ÅܼƬOªÅªº?´N¸õ¨ì¼Ð¥Üi01¦ì¸mÄ~Äò°õ¦æ
   If Y(T1) = "" Then Y(T1) = T2: GoTo i01
   '¡ô¦pªG¥HT1ÅܼƬdY¦r¨å±oitem­È¬O ªÅªº?
   '¬O´N¥OT1ÅܼƷíkey,item¬OT2ÅܼÆ,¯Ç¤JY¦r¨å¤¤,¸õ¨ì¼Ð¥Üi01¦ì¸mÄ~Äò°õ¦æ
   If InStr("," & Y(T1) & ",", "," & T2 & ",") = 0 Then
   '¡ô¦pªG¥HT1Åܼƴ£¨úY¦r¨å¤¤item­È¦³¨S¦³¥]§t T2ÅܼÆ?
   'InStr()¤¤ªº¤¸¯À³£¥H³r¸¹¥]§¨«á¦A§PÂ_,­°§C¥©¦Xªº·N¥~¾÷²v
      Y(T1) = Y(T1) & "," & T2
      '¡ô¥OT1ÅܼƦbY¦r¨å¤¤ªºitem­È³s±µT2ÅܼÆ,¤¤¶¡¥H³r¸¹¹j¶}
   End If
i01: Next
Brr = Range([D2], [D65536].End(3))
'¡ô¥OBrrÅܼƬO¤Gºû°}¦C,´«¸Ë[B2]¨ìAÄæ³Ì«á¤@¦³¤º®eªºÀx¦s®æ­È
ReDim Crr(1 To UBound(Brr), 1 To 1)
'¡ô¥OCrrÅܼƬO ¤GºûªÅ°}¦C,Áa¦V½d³ò¦PBrr°}¦C,¾î¦V1~1
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é
   Crr(i, 1) = Y(Brr(i, 1))
   '¡ô¥OCrr°}¦C­È¬O Brr°}¦C­È¬dY¦r¨åªºitem­È
Next
[E2:E65536].ClearContents
'¡ô¥OÀx¦s®æµ²ªG²M°£
[E2].Resize(UBound(Crr)) = Crr
'¡ô¥O±q[E2]Àx¦s®æ¶}©l¼g¤JCrr°}¦C­È
Set Y = Nothing: Erase Brr, Crr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub