[حل شده] هر رنگ یک کد

[bnyamin]

با سلام
یک فایل هست که در ستون b دارای متن هست
و سطر ها دارای رنگ مختلف ؛ (دارای 6 رنگ و یک رنگ اتوماتیکال در این فایلی که در پیوست قرار میدهم . نهایتا رنگ ها از ده تا بیشتر نمیشوند(در فایلهای دیگر منظورم هست ))
حال میخواهیم هر سطر رنگ مشکی و اتوماتیکال دارای کد zzz باشد و این کد در جلویش در ستون d درج گردد و
بقیه رنگ ها (بغیر از مشکی و اتوماتیکال که کد zzz گرفتن ) به ترتیب حضور از بالا به پایین کد بگیرند .
مثلا اگر اولین رنگ (به غیر از مشکی و اتوماتیکال ) درستون ( از بالا به پایین ) سبز بود مثلا کد aaa بگیرد و همین کد برای بقیه رنگ های سبز در کل ستون اعمال گردد
و اگر دو مین رنگ صورتی بود bbb
و اگر سومین رنگ آبی کم رنگ بود ccc
و اگر چهارمین رنگ آبی پررنگ بود ddd
...
تا ده رنگ
و تمامی این کد ها در ستون d درج گردد.

همین کار را با فیلتر کردن در فایل پیوست بصورت دستی انجام داده ام در شیت دوم مشخصه

امکان دارد مثلا در فایلهای دیگر اولین رنگ صورتی باشد که باید مثلا صورتی aaa بگیرد

و یا در فایل دیگری اولین رنگ آبی باشد که اون باید aaa بگیرد

با تشکر

[M_ExceL]

با سلام،

Sub M_ExceL()

Dim D As Variant
Dim C As New Collection
Dim b As Boolean
Dim i, lstr As Long

lstr = Cells(Rows.Count, 2).End(3).Row

Dim A(1 To 25) As String: i = 1

For ascii = 65 To 89
    A(i) = UCase(WorksheetFunction.Rept(Chr(ascii), 3))
    i = i + 1
Next

On Error Resume Next
For i = 1 To lstr
    If Cells(i, 2).Font.Color <> "0" Then
        C.Add CStr(Cells(i, 2).Font.Color), _
        CStr(Cells(i, 2).Font.Color)
    End If
Next
On Error GoTo 0

Set D = CreateObject("Scripting.Dictionary")

For i = 1 To C.Count
    D.Add C.Item(i), A(i)
Next

For i = 1 To lstr
    For Each itm In D
        If Cells(i, 2).Font.Color = 0 Then
            Cells(i, 4) = "ZZZ"
            Exit For
        ElseIf Cells(i, 2).Font.Color = Int(itm) Then
            Cells(i, 4) = D(itm)
            Exit For
        End If
    Next
Next
End Sub