ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] §ä¥X­«Âиê®Æ

[µo°Ý] §ä¥X­«Âиê®Æ

¦U¦ì¤j¤j,
§Ú¥Î¦³­­ªº¯à¤O¼g¤F¤@­Ó"§ä¥X­«Âиê®Æªºµ{¦¡¡¨, ¦ý§Ú¦³¤@¨Ç°ÝÃD§Ú¥¼¯à¸Ñ¨M,½Ð¦U¦ìÀ°¦£

1.        ¦bHÄæ,¥uÅã¥Ü­«ÂЪºÀx¦s®æ¦ì¸m,¦Ó¤£ÅV¥Ü¥»¨­ªºÀx¦s®æ¦ì¸m
2.        ¦b­«ÂЪº±¡ªp¤U, ¤ñ¦pF2®æ¦³¡¨Y¡¨ªº¦r,¦p¦ó§ä¥X­«ÂЪºÀx¦s®æD86³£¥i¥H¦³¦P¼Ëªº¤å¦r©O?
3.        ¦b¶W¹L2­Ó­«ÂЪº±¡ªp¤U,J Äæ¥i¥H¦h­«Åã¥ÜAÄ檺¦WºÙ,

ÁÂÁÂ

Book1.rar (31.6 KB)

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


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

°õ¦æ«e:


°õ¦æµ²ªG:



Sub TEST_A01()
Dim Arr, xD, i&, T$, T1$, T2$, SR, S, xR As Range, xU As Range
'¡ô«Å§iÅܼÆ
Set xD = CreateObject("Scripting.Dictionary")
'¡ô¥OxDÅܼƬO ¦r¨å
With Range([J1], [A65536].End(3))
'¡ô¥H¤U¬OÃö©ó¥»ªíA~JÄæÀx¦s®æªºµ{§Ç
     .EntireRow.Interior.ColorIndex = xlNone
     '¡ô¥O¸Ó°Ï°ì¥þ¦C©³¦â¬OµL¦â
     .Offset(1, 7).ClearContents
     '¡ô¥O¸Ó°Ï°ì©¹¤U°¾²¾1¦C,©¹¥k7Äæ°Ï°ìÀx¦s®æ²M°£¤º®e
     [H1:J1] = Array("­«ÂЦì¸m", "­«ÂЦ¸¼Æ", "¹ïÀ³³õ¦WºÙ")
     '¡ô¥O[H1:J1]Àx¦s®æ¼g¤J¦C¼ÐÃD
     Arr = .Cells
     '¡ô¥OArrÅܼƬO ¤Gºû°}¦C,¥H¸Ó°Ï°ìÀx¦s®æ­È±a¤J°}¦C¤¤
End With
For i = 2 To UBound(Arr)
'¡ô³]¶¶°j°é
    T = Arr(i, 4): T2 = Arr(i, 6)
    '¡ô¥O¦r¦êÅܼƸˤJ°}¦C­È
    xD(T) = Trim(xD(T) & " " & i)
    '¡ô¥OTÅܼƷíkey,item¬O ¦Û¨­³s±µªÅ¥Õ¦r¤¸,¦A³s±µiÅܼÆ,©Ò²Õ¦¨ªº·s¦r¦ê
    If T2 <> "" Then xD(T & "/y") = T2
    '¡ô¦pªGT2ÅܼƤ£¬OªÅ¦r¤¸!´N¥OTÅܼƳs±µ"/y"²Õ¦¨ªº·s¦r¦ê·íkey,
    'item¬OT2ÅܼÆ,¯Ç¤JxD¦r¨å¤¤

Next i
For i = 2 To UBound(Arr)
'¡ô³]¶¶°j°é
    SR = Split(xD(Arr(i, 4) & ""), " ")
    '¡ô¥OSRÅܼƬO¤@ºû°}¦C:¥H°}¦C²Ä4Äæ­È´£¨úxD¦r¨åitem,
    '¦A¥HªÅ¥Õ¦r¤¸¤À³Î¦¨¬°¤@ºû°}¦C

    If UBound(SR) <= 0 Then GoTo i01
    '¡ô¦pªGSR°}¦C³Ì«á¤@­Ó¯Á¤Þ¸¹<=0,´N¸õ¨ì¼Ð¥Üi0¦ì¸mÄ~Äò°õ¦æ
    T1 = "": T2 = "": Set xR = Range("D" & i)
    '¡ô¥OT1,T2ÅܼƬO ªÅ¦r¤¸,¥OxRÅܼƬO DÄæi¦CÀx¦s®æ
    For Each S In SR
    '¡ô³]³v¶µ°j°é!¥OSÅܼƬOSR°}¦C­È¤§¤@
        If Val(S) <> i Then
        '¡ô¦pªGSÅܼÆÂà¼Æ­È«á »PiÅܼƤ£¦P
           T1 = T1 & "," & "D" & S
           '¡ô¥OT1ÅܼƬO ¦Û¨­³s±µ³r¸¹,¦A³s±µ"D",³Ì«á³s±µSÅܼƦ¨·s¦r¦ê
           T2 = T2 & "," & Arr(S, 1)
           '¡ô¥OT2ÅܼƬO ¦Û¨­³s±µ³r¸¹,¦A³s±µSÅܼƦC²Ä1ÄæArr°}¦C­È
        End If
    Next S
    Arr(i, 6) = xD(Arr(i, 4) & "/y")
    '¡ô¥O°j°é¦C²Ä6ÄæArr°}¦C­È¬O °j°é¦C²Ä6ÄæArr°}¦C­È³s±µ"/y"¦¨ªº·s¦r¦ê,¬d
    '¬dxD¦r¨å¦^¶Çªºitem­È

    Arr(i, 8) = Mid(T1, 2)
    '¡ô¥O°j°é¦C²Ä8ÄæArr°}¦C­È¬O T1Åܼƨú²Ä2¦r¥H«áªº¥þ³¡¦r¦ê
    Arr(i, 9) = UBound(SR) + 1
    '¡ô¥O°j°é¦C²Ä9ÄæArr°}¦C­È¬O SR°}¦C³Ì¤j¯Á¤Þ¸¹+1
    Arr(i, 10) = Mid(T2, 2)
    '¡ô¥O°j°é¦C²Ä10ÄæArr°}¦C­È¬O T2Åܼƨú²Ä2¦r¥H«áªº¥þ³¡¦r¦ê
    If xU Is Nothing Then Set xU = xR Else Set xU = Union(xU, xR)
    '¡ô¦pªGxUÅܼƬOªÅªº,´N¥OxUÅܼƬOxRÅܼÆ,§_«h´N±NxRÅܼƯǤJxUÀx¦s®æ¶°¸Ì
i01: Next i
[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
'¡ô¥OArr°}¦C±q[A1]¶}©l¼g¤J½d³òÀx¦s®æ¤¤
If Not xU Is Nothing Then xU.EntireRow.Interior.ColorIndex = 6
'¡ô¦pªGxUÅܼƤ£¬OªÅªº,´N¥O¸ÓxUÀx¦s®æ¶°©Ò¦bªº¦C¾ã¦C©³¦â¬°¶À¦â
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

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


  
­ã´£³¡ªL®v¥S¡A
¯uªº¤Q¤À·P¿E§AªºÀ°¦£¡AÁÂÁ§A

TOP

¦^´_ 10# samwang


   
Samsung ®v¥S¡A
¸U¤À·PÁ§AÀ°¦£¡AÁÂÁÂ

TOP

¦^´_ 9# °a¤ªºµ
   
°a¤ªºµ®v¥S¡A
·PÁ§A¦Ê¦£¤¤À°¦£¡AÁÂÁ§A

TOP

¦^´_ 8# ML089

ML089®v¥S¡A
¯uªºÁÂÁ§AÀ°¦£

TOP

ARRAY ³B²z¸ê®Æ
RANGE-UNION¶ñ¦â
Xl0000207.rar (52.52 KB)

TOP

¦^´_ 7# mdr0465


½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C

Sub test()
Dim xD, Arr, Brr(), i&, Ar, a&, b$, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([F1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 1 To UBound(Arr)
    If xD.Exists(Arr(i, 4) & "") Then
        m = m + 1
        ¦C = xD(Arr(i, 4) & "")
        Brr(¦C, 3) = Brr(¦C, 3) & "_" & m
        Brr(¦C, 4) = Brr(¦C, 4) & "_" & Arr(i, 1)
    Else
        m = m + 1
        xD(Arr(i, 4) & "") = i
        Brr(m, 2) = Arr(i, 4)
        Brr(m, 3) = m
        Brr(m, 4) = Arr(i, 1)
    End If
Next

For i = 1 To UBound(Arr)
    For ib = 1 To UBound(Brr)
        pos = InStr(Brr(ib, 3), "_")
        If pos > 0 And Arr(i, 4) = Brr(ib, 2) Then
            Ar = Split(Brr(ib, 3), "_")
            For j = 0 To UBound(Ar)
                a = Split(Brr(ib, 3), "_")(j)
                b = Split(Brr(ib, 4), "_")(j)
                If i <> a Then
                    If Cells(i, 8) = "" Then
                        Cells(i, 8) = "D" & a
                        Cells(i, 9) = b
                        Rows(i).EntireRow.Interior.ColorIndex = 6
                    Else
                        Cells(i, 8) = Cells(i, 8) & "," & "D" & a
                        Cells(i, 9) = Cells(i, 9) & "," & b
                    End If
                End If
            Next
        End If
    Next
Next
End Sub

TOP

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2021-3-5 22:04 ½s¿è

¦^´_ 7# mdr0465

«Øij§A¥Î  ML089ª©¤j ªº­×§ï ­è¤~´ú¸Õ ¸ê®Æ¹L¦hªº¸Ü ¤£·|¤ÓºC...¦Ó¥BÅÞ¿è«Ü²M·¡
  1. Sub test()

  2.     Dim D As Object, R, x, k

  3.     Application.ScreenUpdating = False
  4.     [A2:A10000].EntireRow.Interior.ColorIndex = xlNone
  5.     [H2:J10000].Clear

  6.     Set D = CreateObject("Scripting.Dictionary")
  7.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  8.         R.Interior.ColorIndex = xlNone
  9.         If Not D.Exists(R.Value) Then
  10.             Set D(R.Value) = R
  11.         Else
  12.             Set D(R.Value) = Union(D(R.Value), R)
  13.         End If
  14.     Next
  15.     [H1] = "¹q¸Ü­«ÂÐÀx¦s®æ¦ì¸m"
  16.     [I1] = "¹ïÀ³³õªº¦WºÙ"
  17.     For Each R In D.KEYS
  18.         If D(R).Cells.Count > 1 Then
  19.             D(R).EntireRow.Interior.ColorIndex = 6
  20.             For Each x In D(R)
  21.                 x¦ì¸m = ""
  22.                 x³õ¦a = ""
  23.                 For Each k In D(R)
  24.                     If x.Address <> k.Address Then
  25.                         x¦ì¸m = x¦ì¸m & "," & k.Address(0, 0)
  26.                         x³õ¦a = x³õ¦a & "," & k.Offset(0, -3)
  27.                     End If
  28.                 Next

  29.                 x.Offset(0, 2) = "Y"

  30.                 x.Offset(0, 4) = Mid(x¦ì¸m, 2, 99)
  31.                 x.Offset(0, 5) = Mid(x³õ¦a, 2, 99)
  32.             Next
  33.         End If
  34.     Next
  35.     Application.ScreenUpdating = True
  36. End Sub
½Æ»s¥N½X

TOP

¦^´_ 7# mdr0465
  1. Sub test()

  2.     Dim D As Object, R, x, k

  3.     Application.ScreenUpdating = False
  4.     [A2:A10000].EntireRow.Interior.ColorIndex = xlNone
  5.     [H2:J10000].Clear

  6.     Set D = CreateObject("Scripting.Dictionary")
  7.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  8.         R.Interior.ColorIndex = xlNone
  9.         If Not D.Exists(R.Value) Then
  10.             Set D(R.Value) = R
  11.         Else
  12.             Set D(R.Value) = Union(D(R.Value), R)
  13.         End If
  14.     Next
  15.     [H1] = "¹q¸Ü­«ÂÐÀx¦s®æ¦ì¸m"
  16.     [I1] = "¹ïÀ³³õªº¦WºÙ"
  17.     For Each R In D.KEYS
  18.         If D(R).Cells.Count > 1 Then
  19.             D(R).EntireRow.Interior.ColorIndex = 6
  20.             For Each x In D(R)
  21.                 x¦ì¸m = ""
  22.                 x³õ¦a = ""
  23.                 For Each k In D(R)
  24.                     If x.Address <> k.Address Then
  25.                         x¦ì¸m = x¦ì¸m & "," & k.Address(0, 0)
  26.                         x³õ¦a = x³õ¦a & "," & k.Offset(0, -3)
  27.                     End If
  28.                 Next
  29.                 x.Offset(0, 4) = Mid(x¦ì¸m, 2, 99)
  30.                 x.Offset(0, 5) = Mid(x³õ¦a, 2, 99)
  31.             Next
  32.         End If
  33.     Next
  34.     Application.ScreenUpdating = True
  35. End Sub
½Æ»s¥N½X
{...} ªí¥Ü»Ý­n¥Î CTRL+SHIFT+ENTER ¤TÁä¿é¤J¤½¦¡

TOP

        ÀR«ä¦Û¦b : ¬°¦Û¤v§äÂǤfªº¤H¥Ã»·¤£·|¶i¨B¡C
ªð¦^¦Cªí ¤W¤@¥DÃD