samwang

¦^´_ 5# mdr0465

¤£¤Ó¯à²z¸Ñ±z©Ò´y­zªº°ÝÃD¡A¥i§_½Ð±zª½±µ±N¹ê»Úªº»Ý¨Dªþ¤W¸Ñµª¦ÓªþÀɤW¨Ó
¸ê®Æ¤ñ¼Æ¥i¥H¤Ö¤@ÂI
ÁÂÁÂ

samwang

¦^´_ 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