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

[امين اسماعيلي]

با درود
از همه دوستانی که این مدت نبودم معذرت میخوام . خوب حالم خوب نبود دعوام نکنین حاله دیگه خراب میشه. خوب بریم سر قصه امشب
شاید برای همه ما پیش اومده باشه که بخواهیم کد رنگ ها و فونت ها و ...... رو در ویژوال به درستی به کار ببریم و از کد اون مطلع نباشیم . کد زیر یه شیت براتون ایجاد میکنه و مشکلتون رو حل میکنه .





Sub colors()

ActiveWorkbook.Sheets.Add

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.Range("A1:H1").Value = Array("interior", "font", "HTML", "bgcolor=", "Red", "Green", "Blue", "Color")
Range("E1").Font.ColorIndex = 3
Range("F1").Font.ColorIndex = 4
Range("G1").Font.ColorIndex = 5
Range("A2").Font.ColorIndex = 2
Range("D2").Font.ColorIndex = 2
Range("H2").Font.ColorIndex = 2
Dim i As Long
Dim str0 As String, str As String
For i = 1 To 56
Cells(i + 1, 1).Interior.ColorIndex = i
Cells(i + 1, 1).Value = "[Color " & i & "]"
Cells(i + 1, 2).Font.ColorIndex = i
Cells(i + 1, 2).Value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.Color), 6)
'Excel shows nibbles in reverse order so make it as RGB
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
'generating 2 columns in the HTML table
Cells(i + 1, 3) = "#" & str
Cells(i + 1, 4) = "#" & str
Cells(i + 1, 4).Interior.ColorIndex = i
Cells(i + 1, 5).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i + 1, 6).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i + 1, 7).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i + 1, 8) = "[Color " & i & "]"
Next i
Range("H2").Value = "vbBlack"
Range("H2").Interior.Color = vbBlack
Range("H3").Value = "vbWhite"
Range("H3").Interior.Color = vbWhite
Range("H4").Value = "vbRed"
Range("H4").Interior.Color = vbRed
Range("H5").Value = "vbGreen"
Range("H5").Interior.Color = vbGreen
Range("H6").Value = "vbBlue"
Range("H6").Interior.Color = vbBlue
Range("H7").Value = "vbYellow"
Range("H7").Interior.Color = vbYellow
Range("H8").Value = "vbMagenta"
Range("H8").Interior.Color = vbMagenta
Range("H9").Value = "vbCyan"
Range("H9").Interior.Color = vbCyan
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub



خوب خوب با این اعداد اشنا بشین . یه ماژوا ایجاد کنید . دیگه توضیح نمیدم قبلا روش ایجاد ماژول تو محیط VBA گفته شد . بعدش کد های زیر رو در انجا کپی و RUN کنید ( F5 )

در ادامه شب های بعد در همین تاپیک با کد نویسی با این اعداد بیشتر اشنا میشیم.

[~M*E*H*D*I~]

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

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

[امين اسماعيلي]

با درود
کد زیر رو من گشتم و تو 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






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

با ددرود

[امين اسماعيلي]

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



'---------------------------------------------------------------------
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~]

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

[~M*E*H*D*I~]

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

[امين اسماعيلي]

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

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

در ضمن لینک زیر رو یه نگاهی بنداز
http://www.xldynamic.com/source/xld.CFConditions.html