هزار و یک شب اکسل - شب چهل و دوم پیدا کردن کد رنگ ها در اکسل 56 Excel ColorIndex Colors

**~M*E*H*D*I~** · 2014/05/05, 08:46

تشکر از مهندس اسماعیلی عزیز

امین جان به نظرت برای تشخیص رنگ های کاندیشنال فرمتینگ در ورژن های بالاتر از 2003 راهی هست؟

**امين اسماعيلي** · 2014/05/05, 15:25

با درود
کد زیر رو من گشتم و تو 2010 تست کردم جواب داد فقط نقصش تو Conditional formating رو String هست مهدی فک کنم . رو اعداد که خوب جواب داد

کد:

' Arguments
' ----------------
' Cell - Required Range, not a String value, for a **single** cell
'
' CellInterior - Optional Boolean (Default = True)
'                True makes function return cell's Interior Color or ColorIndex based on
'                the ReturnColorIndex argument False makes function return Font's Color or
'                ColorIndex based on the ReturnColorIndex argument
'
' ReturnColorIndex - Optional Boolean (Default = True)
'                    True makes function return the ColorIndex for the cell property determined
'                    by the CellInterior argument False make function return the Color for the
'                    cell property determined by the CellInterior argument
'
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
                        Optional ReturnColorIndex As Long = True) As Long
  Dim X As Long, Test As Boolean, CurrentCell As String
  If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
  CurrentCell = ActiveCell.Address
  For X = 1 To Cell.FormatConditions.Count
    With Cell.FormatConditions(X)
      If .Type = xlCellValue Then
        Select Case .Operator
          Case xlBetween:      Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
          Case xlNotBetween:   Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
          Case xlEqual:        Test = Evaluate(.Formula1) = Cell.Value
          Case xlNotEqual:     Test = Evaluate(.Formula1) <> Cell.Value
          Case xlGreater:      Test = Cell.Value > Evaluate(.Formula1)
          Case xlLess:         Test = Cell.Value < Evaluate(.Formula1)
          Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
          Case xlLessEqual:    Test = Cell.Value <= Evaluate(.Formula1)
        End Select
      ElseIf .Type = xlExpression Then
        Application.ScreenUpdating = False
        Cell.Select
        Test = Evaluate(.Formula1)
        Range(CurrentCell).Select
        Application.ScreenUpdating = True
      End If
      If Test Then
        If CellInterior Then
          DisplayedColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
        Else
          DisplayedColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
        End If
        Exit Function
      End If
    End With
  Next
  If CellInterior Then
    DisplayedColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
  Else
    DisplayedColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
  End If
End Function

هر چن اینم نقص هایی داره اما چک کن تا ببینم چیز بهتر چی چیدا میشه

با ددرود

**امين اسماعيلي** · 2014/05/05, 17:37

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

کد:

'---------------------------------------------------------------------
Public Function CFColorindex(rng As Range)
'---------------------------------------------------------------------
Dim oFC As FormatCondition
Dim sF1 As String
Dim iRow As Long
Dim iColumn As Long

   Set rng = rng(1, 1)
   If rng.FormatConditions.Count > 0 Then
      For Each oFC In rng.FormatConditions
         If oFC.Type = xlCellValue Then
            Select Case oFC.Operator
               Case xlEqual
                  CFColorindex = rng.Value = oFC.Formula1
               Case xlNotEqual
                  CFColorindex = rng.Value <> oFC.Formula1
               Case xlGreater
                  CFColorindex = rng.Value > oFC.Formula1
               Case xlGreaterEqual
                  CFColorindex = rng.Value >= oFC.Formula1
               Case xlLess
                  CFColorindex = rng.Value < oFC.Formula1
               Case xlLessEqual
                  CFColorindex = rng.Value <= oFC.Formula1
               Case xlBetween
                  CFColorindex = (rng.Value >= oFC.Formula1 And _
                             rng.Value <= oFC.Formula2)
               Case xlNotBetween
                  CFColorindex = (rng.Value < oFC.Formula1 Or _
                             rng.Value > oFC.Formula2)
            End Select
         Else
             're-adjust the formula back to the formula that applies
             'to the cell as relative formulae adjust to the activecell
            With Application
               iRow = rng.row
               iColumn = rng.Column
               sF1 = .Substitute(oFC.Formula1, "ROW()", iRow)
               sF1 = .Substitute(sF1, "COLUMN()", iColumn)
               sF1 = .ConvertFormula(sF1, xlA1, xlR1C1)
               sF1 = .ConvertFormula(sF1, xlR1C1, xlA1, , rng)
            End With
            CFColorindex = rng.Parent.Evaluate(sF1)
         End If

         If CFColorindex Then
            If Not IsNull(oFC.Interior.ColorIndex) Then
               CFColorindex = oFC.Interior.ColorIndex
               Exit Function
            End If
         End If
     Next oFC
   End If 'rng.FormatConditions.Count > 0

End Function

**~M*E*H*D*I~** · 2014/05/05, 21:00

با روش های مختلف تست کردم ظاهرا کد پست 3 بهتر جواب میده کد پست 4 ایراد داره

**~M*E*H*D*I~** · 2014/05/05, 21:50

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

فایل های پیوست شده

conditionalformatting.xlsm (29.3 کیلو بایت, مشاهدات 14)

**امين اسماعيلي** · 2014/05/06, 03:23

با درود
مهدی ببین تو Top رنک که میخوای با فرمول نمیتونی به جواب برسی . از طریق فرمول کاندیشن ببندی

فایل زیر رو من میزارم برات هر چی کد دیدم برات گذاشتم

در ضمن لینک زیر رو یه نگاهی بنداز

AKAI123 : Gaskan Bermain Tanpa Rugi! Klaim Bonus Tanpa Syarat Cuma Disini!

http://www.xldynamic.com/source/xld.CFConditions.html

AKAI123 Menang atau kalah, tetap dapat banyak bonus! Jangan ragu untuk terus bermain karena setiap kesempatan memberikan hadiah yang bisa langsung diklaim.

فایل های پیوست شده