رنگی کردن سلول با داده های یکسان

Collapse
X
 
  • زمان
  • نمایش
حذف همه
new posts
  • chicamika

    • 2016/09/04
    • 89
    • 46.00

    پرسش رنگی کردن سلول با داده های یکسان

    سلام و عرض ادب.من میخوام تو اکسل سلولهایی که دارای داده های یکسان هستند متمایز بشن(رنگی بشن)حال مشکل اینجاست که میخوام مجدد هر دیتای تکراری با رنگ خاصی متمایز از داده های تکراری دیگر نمایش داده بشه .توضیحات در فایل پیوست .با تشکر
    فایل های پیوست شده
  • rahi_feri

    • 2014/08/08
    • 524
    • 94.67

    #2
    با conditional میشه البته نه خیلی دقیق این که کد بدید به اسم ها و کد ها رو با scaling رنگی کنید...پیشنهاد من ماکرو هست در کد زیر رنج رو انتخاب کنید و ماکرو رو ران کنید
    کد:
    Sub ColorDuplicates()
    Dim x As Integer
    Dim y As Integer
    Dim lRows As Long
    Dim lColNum As Long
    Dim iColor As Integer
    Dim iDupes As Integer
    Dim bFlag As Boolean
    
    lRows = Selection.Rows.Count + 1
    lColNum = Selection.Column
    iColor = 2
    
        For x = 2 To lRows
            bFlag = False
            For y = 2 To x - 1
                If Cells(y, lColNum) = Cells(x, lColNum) Then
                    bFlag = True
                    Exit For
                End If
            Next y
            If Not bFlag Then
                iDupes = 0
                For y = x + 1 To lRows
                    If Cells(y, lColNum) = Cells(x, lColNum) Then
                        iDupes = iDupes + 1
                    End If
                Next y
                If iDupes > 0 Then
                    iColor = iColor + 1
                    If iColor > 56 Then
                        MsgBox "Too many duplicate companies!", vbCritical
                        Exit Sub
                    End If
                    Cells(x, lColNum).Interior.ColorIndex = iColor
                    For y = x + 1 To lRows
                        If Cells(y, lColNum) = Cells(x, lColNum) Then
                            Cells(y, lColNum).Interior.ColorIndex = iColor
                        End If
                    Next y
                End If
            End If
        Next x
    End Sub
    خروجی:
    Click image for larger version

Name:	2023-05-17_15-53-25.png
Views:	1
Size:	2.0 کیلو بایت
ID:	139623
    [B][SIZE=1]بخش امضاء :
    [/SIZE][/B][LEFT]
    [CODE]
    Sub Macro()
    ActiveCell = "IY" & Right(Application.Name, 5)
    With ActiveCell.Characters(Start:=2, Length:=1).Font
    .Name = "Webdings"
    .Color = 255
    End With
    End Sub
    [/CODE]
    [/LEFT]

    کامنت

    چند لحظه..