• توابع رنگ در اکسل

    در این پست توابع VBA را که می توانید از آنها برای کار با رنگ ها در برگه ها استفاده کنید بیان می کنیم

    اکسل اساساً هیچ پشتیبانی در توابع کاربرگ برای کار با رنگ های سلولی ارائه نمی دهد. با این حال، رنگ ها اغلب در صفحات گسترده برای نشان دادن نوعی ارزش یا دسته استفاده می شوند. بنابراین نیاز به توابعی است که می تواند با رنگ ها در کاربرگ کار کند. این صفحه تعدادی از توابع را برای VBA توصیف می کند که می توانند از سلول های کاربرگ یا سایر رویه های VBA فراخوانی شوند.

     

    معرفی سریع رنگ ها

    مانند هر چیز دیگری در رایانه، یک رنگ در واقع فقط یک عدد است. هر رنگی که می تواند بر روی صفحه نمایش کامپیوتر نمایش داده شود بر حسب سه جزء اصلی تعریف می شود: یک جزء قرمز، یک جزء سبز و یک جزء آبی. در مجموع، این مقادیر به عنوان مقادیر RGB شناخته می شوند. مدل رنگی RGB مدل «افزودنی» نامیده می‌شود، زیرا رنگ‌های غیراصولی دیگر، مانند بنفش، از ترکیب رنگ‌های اصلی قرمز، سبز و آبی در درجات مختلف ایجاد می‌شوند. به عنوان مثال، بنفش تقریباً یک قرمز با شدت نیمه به اضافه یک آبی با شدت نیمه است. هر جزء رنگ اصلی به عنوان یک عدد بین 0 تا 255 (یا به صورت هگز، &H00 تا &HFF) ذخیره می شود. یک رنگ یک عدد 4 بایتی با فرمت 00BBGGRR است که مقادیر RR، GG و BB مقادیر قرمز، سبز و آبی هستند که هر کدام بین 0 تا 255 (&HFF) هستند. اگر تمام مقادیر مؤلفه 0 باشد، رنگ RGB 0 است که سیاه است. اگر همه مقادیر مؤلفه 255 (&HFF) باشد، رنگ RGB 16777215 (&H00 FFFFFF) یا سفید است. همه رنگ های دیگر ترکیبی از مقادیر برای اجزای قرمز، سبز و آبی هستند. تابع VBA RGB را می توان برای ترکیب مقادیر قرمز، سبز و آبی به یک مقدار رنگ RGB استفاده کرد.

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

    ارزش جلب توجه به مقادیر مؤلفه در مقدار Long RGB را دارد. ترتیب رنگ‌ها از چپ به راست که در مقدار RGB ذخیره می‌شوند آبی، سبز، قرمز است. این برعکس حروف در نام RGB است. این را در هنگام استفاده از حروف هگزا برای تعیین رنگ در نظر داشته باشید.

     

    پالت رنگ

    اکسل از رنگ‌ها برای فونت‌ها و پر کردن پس‌زمینه از طریق آنچه که پالت رنگ نامیده می‌شود، پشتیبانی می‌کند. پالت یک آرایه یا سری از 56 رنگ RGB است. ارزش هر یک از آن 56 رنگ ممکن است هر یک از 16 میلیون رنگ موجود باشد، اما پالت، و بنابراین تعداد رنگ های متمایز در یک کتاب کار، به 56 رنگ محدود می شود. مقادیر RGB در پالت با ویژگی ColorIndex یک شی Font (برای رنگ فونت) یا شی داخلی (برای رنگ پس‌زمینه) قابل دسترسی است. ColorIndex یک افست یا شاخص در پالت است و بنابراین دارای مقداری بین 1 و 56 است. در پالت پیش‌فرض و اصلاح نشده، عنصر سوم در پالت مقدار RGB 255 (&HFF) است که قرمز است.

    برای مثال، وقتی پس‌زمینه سلولی را به رنگ قرمز فرمت می‌کنید، در واقع مقدار 3 را به ویژگی ColorIndex داخلی اختصاص می‌دهید. اکسل عدد 3 را در ویژگی ColorIndex می‌خواند، به عنصر سوم پالت می‌رود تا RGB واقعی را دریافت کند. رنگ اگر پالت را تغییر دهید، مثلاً با تغییر عنصر سوم از قرمز (255 = &HFF) به آبی (16,711,680 = &HFF0000)، همه مواردی که زمانی قرمز بودند اکنون آبی هستند. این به این دلیل است که ویژگی ColorIndex برابر با 3 است، اما مقدار عنصر سوم در پالت از قرمز به آبی تغییر کرده است.

    شما مقادیر موجود در پالت پیش فرض را با تغییر آرایه Colors شی Workbook تغییر می دهید. به عنوان مثال، برای تغییر رنگ ارجاع شده توسط مقدار ColorIndex 3 به آبی، از استفاده کنید
     

    Workbooks("SomeBook.xls").Colors(3) = RGB(0,0,255)



    علاوه بر 56 رنگ موجود در پالت، دو مقدار خاص برای رنگ ها استفاده می شود که در ادامه با آن ها مواجه خواهیم شد. اینها xlColorIndexNone هستند که مشخص می‌کند هیچ رنگی اختصاص داده نشده است، و xlColorIndexAutomatic، که مشخص می‌کند یک رنگ پیش‌فرض سیستم (معمولاً سیاه) باید استفاده شود.

    توجه: این توابع فقط با پالت 56 رنگ اکسل کار می کنند. آن‌ها از رنگ‌های تم یا رنگ‌هایی که در پالت 56 رنگ نیستند یا رنگ‌هایی که نتیجه قالب‌بندی شرطی هستند پشتیبانی نمی‌کنند.

     

    نمایش پالت کتاب کار فعلی

    می توانید از کدهای بسیار ساده برای نمایش تنظیمات فعلی پالت رنگ استفاده کنید. کد زیر رنگ 56 سلول اول کاربرگ فعال را به رنگ های پالت تغییر می دهد. شماره ردیف همان عدد شاخص رنگ است. بنابراین، سلول A3 که در ردیف 3 قرار دارد، رنگی خواهد بود که به شاخص رنگ 3 اختصاص داده شده است.

    Sub Displaypalette()
        Dim N As Long
        For N = 1 To 56
            Cells(N, 1).Interior.ColorIndex = N
        Next N
    End Sub

    اگر با استفاده از Workbook.Colors پالت کتاب کار را تغییر داده اید، می توانید با Workbooks("SomeBook.xls").ResetColors پالت را به مقادیر پیش فرض بازگردانید.

     

    نگ ها در یک سلول یا محدوده

    این بحث در مورد رنگ ها، پالت رنگ و ویژگی ColorIndex ما را به عملکرد اساسی اکثر کدهایی که در این صفحه توضیح داده شده است هدایت می کند. تابع ColorIndexOfOneCell شاخص رنگ پس زمینه یا فونت یک سلول را برمی گرداند. بیانیه رویه در زیر نشان داده شده است.

    Function ColorIndexOfOneCell(Cell As Range, OfText As Boolean, DefaultColorIndex As Long) As Long

    در اینجا Cell سلولی است که رنگ آن خوانده می شود. OfText یا True یا False است که نشان می دهد آیا باید شاخص رنگ فونت (OfText = True) یا پس زمینه (OfText = False) را برگردانید. پارامتر DefaultColorIndex یک مقدار شاخص رنگ (1 تا 56) است که اگر رنگ خاصی به فونت (xlColorIndexAutomatic) یا پر کردن پس زمینه (xlColorIndexNone) اختصاص داده نشده باشد، باید برگردانده شود. اگر OfText را روی True تنظیم کنید، به احتمال زیاد باید DefaultColorIndex را روی 1 (سیاه) تنظیم کنید. اگر OfText را روی False تنظیم کنید، باید DefaultColorIndex را روی 2 (سفید) قرار دهید. به عنوان مثال، اگر محدوده A1 دارای یک پس زمینه پر شده برابر با قرمز باشد (ColorIndex = 3)، کد:

    Dim Result As Long
    Result = ColorIndexOfOneCell(Cell:=Range("A1"), OfText:=False, DefaultColorIndex:=1)
     

    3 را برمی گرداند. این را می توان مستقیماً از یک سلول کاربرگ با فرمولی مانند:

     

    =COLORINDEXOFONECELL(A1,FALSE,1) 

    تابع ColorIndexOfOneCell کامل به شرح زیر است:

        Function ColorIndexOfOneCell(Cell As Range, OfText As Boolean, _
            DefaultColorIndex As Long) As Long
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' ColorIndexOfOneCell
        ' This returns the ColorIndex of the cell referenced by Cell.
        ' If Cell refers to more than one cell, only Cell(1,1) is
        ' tested. If OfText True, the ColorIndex of the Font property is
        ' returned. If OfText is False, the ColorIndex of the Interior
        ' property is returned. If DefaultColorIndex is >= 0, this
        ' value is returned if the ColorIndex is either xlColorIndexNone
        ' or xlColorIndexAutomatic.
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Dim CI As Long
        
        Application.Volatile True
        If OfText = True Then
            CI = Cell(1, 1).Font.ColorIndex
        Else
            CI = Cell(1, 1).Interior.ColorIndex
        End If
        If CI < 0 Then
            If IsValidColorIndex(ColorIndex:=DefaultColorIndex) = True Then
                CI = DefaultColorIndex
            Else
                CI = -1
            End If
        End If
        
        ColorIndexOfOneCell = CI
        
        End Function
    
        Private Function IsValidColorIndex(ColorIndex As Long) As Boolean 
            Select Case ColorIndex 
                Case 1 To 56 
                    IsValidColorIndex = True 
                Case xlColorIndexAutomatic, xlColorIndexNone  
                    IsValidColorIndex = True 
                Case Else 
                    IsValidColorIndex = False 
            End Select 
        End Function 
    

    تابع ColorIndexOfOneCell به خودی خود کاربرد محدودی دارد. با این حال، تابع دیگری به نام ColorIndexOfRange استفاده می‌کند که آرایه‌ای از مقادیر شاخص رنگ را برای محدوده‌ای از سلول‌ها برمی‌گرداند. اعلان این تابع در زیر نشان داده شده است:

    Function ColorIndexOfRange(InRange As Range, _
                       Optional OfText As Boolean = False, _
                       Optional DefaultColorIndex As Long = -1) As Variant

    در اینجا، InRange محدوده ای است که مقادیر رنگ آن باید برگردانده شود. OfText یا True یا False است که نشان می دهد آیا باید شاخص رنگ فونت (OfText = True) یا پر کردن پس زمینه (OfText = نادرست یا حذف شده) سلول های InRange را بررسی کنیم. مقدار DefaultColorIndex یک شاخص رنگ را مشخص می‌کند که اگر مقدار شاخص رنگ واقعی xlColorIndexNone یا xlColorIndexAutomatic باشد، باید برگردانده شود. این تابع آرایه ای از مقادیر شاخص رنگ (1 تا 56) از هر سلول در InRange را به عنوان نتیجه خود برمی گرداند.

    می‌توانید ColorIndexOfRange را به‌عنوان یک فرمول آرایه از محدوده‌ای از سلول‌ها فراخوانی کنید تا شاخص‌های رنگ محدوده دیگری از سلول‌ها را برگردانید. مثلاً اگر array-enter کنید

    =ColorIndexOfRange(A1:A10,FALSE,1)

    در سلول های B1:B10، B1:B10 شاخص های رنگ سلول ها را در A1:A10 فهرست می کند.

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

    Function ColorIndexOfRange(InRange As Range, _
            Optional OfText As Boolean = False, _
            Optional DefaultColorIndex As Long = -1) As Variant
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' ColorIndexFromRange
        ' This function returns an array of values, each of which is
        ' the ColorIndex of a cell in InRange. If InRange contains both
        ' multiple rows and multiple columns, the array is two dimensional,
        ' number of rows x number of columns. If InRange is either a single
        ' row or a single column, the array is single dimensional. If
        ' InRange has multiple rows, the array is transposed before
        ' returning it. The DefaultColorIndex indicates what color
        ' index to value to substitute for xlColorIndexNone and
        ' xlColorIndexAutomatic. If OfText is True, the ColorIndex
        ' of the cell's Font property is returned. If OfText is False
        ' or omitted, the ColorIndex of the cell's Interior property
        ' is returned.
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        Dim Arr() As Long
        Dim NumRows As Long
        Dim NumCols As Long
        Dim RowNdx As Long
        Dim ColNdx As Long
        Dim CI As Long
        Dim Trans As Boolean
        
        Application.Volatile True
        If InRange Is Nothing Then
            ColorIndexOfRange = CVErr(xlErrRef)
            Exit Function
        End If
        If InRange.Areas.Count > 1 Then
            ColorIndexOfRange = CVErr(xlErrRef)
            Exit Function
        End If
        If (DefaultColorIndex < -1) Or (DefaultColorIndex > 56) Then
            ColorIndexOfRange = CVErr(xlErrValue)
            Exit Function
        End If
        
        NumRows = InRange.Rows.Count
        NumCols = InRange.Columns.Count
        
        If (NumRows > 1) And (NumCols > 1) Then
            ReDim Arr(1 To NumRows, 1 To NumCols)
            For RowNdx = 1 To NumRows
                For ColNdx = 1 To NumCols
                    CI = ColorIndexOfOneCell(Cell:=InRange(RowNdx, ColNdx), _
                        OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
                    Arr(RowNdx, ColNdx) = CI
                Next ColNdx
            Next RowNdx
            Trans = False
        ElseIf NumRows > 1 Then
            ReDim Arr(1 To NumRows)
            For RowNdx = 1 To NumRows
                CI = ColorIndexOfOneCell(Cell:=InRange.Cells(RowNdx, 1), _
                    OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
                Arr(RowNdx) = CI
            Next RowNdx
            Trans = True
        Else
            ReDim Arr(1 To NumCols)
            For ColNdx = 1 To NumCols
                CI = ColorIndexOfOneCell(Cell:=InRange.Cells(1, ColNdx), _
                    OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
                Arr(ColNdx) = CI
            Next ColNdx
            Trans = False
        End If
    
        If IsObject(Application.Caller) = False Then
            Trans = False
        End If
        
        If Trans = False Then
            ColorIndexOfRange = Arr
        Else
            ColorIndexOfRange = Application.Transpose(Arr)
        End If
        
        End Function

    می‌توانید از تابع ColorIndexOfRange در کدهای دیگر استفاده کنید، مانند:

    Sub AAA()
            Dim V As Variant
            Dim N As Long
            Dim RR As Range
            Set RR = Range("ColorCells")
            V = ColorIndexOfRange(InRange:=RR, OfText:=False, DefaultColorIndex:=1)
            If IsError(V) = True Then
                Debug.Print "*** ERROR: " & CStr(V)
                Exit Sub
            End If
            If IsArray(V) = True Then
                For N = LBound(V) To UBound(V)
                    Debug.Print RR(N).Address, V(N)
                Next N
            End If
        End Sub

     

     

    تغییر رنگ و محاسبه

    اکسل معمولاً زمانی که سلولی که فرمول به آن بستگی دارد تغییر می کند، فرمول را در یک سلول محاسبه می کند. به عنوان مثال، فرمول =SUM(A1:A10) هنگامی که هر سلول در A1:A10 تغییر می کند، دوباره محاسبه می شود. با این حال، اکسل تغییر رنگ سلول را برای محاسبه مهم در نظر نمی گیرد و بنابراین لزوماً هنگام تغییر رنگ سلول، فرمول را دوباره محاسبه نمی کند. در ادامه این صفحه، تابعی به نام CountColor را مشاهده خواهیم کرد که تعداد سلول های یک محدوده را که دارای شاخص رنگ خاصی هستند، می شمارد. اگر رنگ سلولی را در محدوده ای که به CountColor ارسال می شود تغییر دهید، اکسل تابع CountColor را مجدداً محاسبه نمی کند و بنابراین، نتیجه CountColor ممکن است تا زمانی که محاسبه مجدد انجام نشود، با رنگ های واقعی در کاربرگ مطابقت نداشته باشد. توابع مربوطه از Application.Volatile True برای وادار کردن آنها به محاسبه مجدد در هنگام انجام هر گونه محاسبه استفاده می کنند، اما این هنوز کافی نیست. تغییر ساده رنگ سلول باعث محاسبه نمی شود، بنابراین تابع حتی با Application.Volatile True دوباره محاسبه نمی شود.

     

     

    شبیه سازی یک رویداد تغییر رنگ

    در حالی که اکسل هیچ رویدادی برای تغییر رنگ سلول ارائه نمی دهد، می توانید از رویداد Worksheet_Change برای تشخیص اینکه آیا کاربر وارد محدوده ColorCells شده و آیا کاربر از محدوده ColorCells خارج می شود یا خیر استفاده کنید.

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
            Static OldCell As Excel.Range
            If OldCell Is Nothing Then
                Set OldCell = ActiveCell
            End If
            ' movement within ColorCells:
            If Not Application.Intersect(Target(1, 1), Range("ColorCells")) Is Nothing Then
                Me.Calculate
            ' movement out
            ElseIf Application.Intersect(Target(1, 1), Range("ColorCells")) Is Nothing Then
                If Not Application.Intersect(OldCell, Range("ColorCells")) Is Nothing Then
                    Me.Calculate
                End If
            End If
            Set OldCell = Target(1, 1)
        End Sub

    این کد آزمایش می کند که آیا کاربر انتخاب را از یک سلول در ColorCells به سلول دیگر در ColorCells تغییر داده است یا خیر، و کاربرگ را دوباره محاسبه می کند. این کد همچنین آزمایش می کند که آیا کاربر انتخاب را از سلولی در ColorCells به سلولی خارج از ColorCells منتقل می کند یا خیر. اگر این درست باشد، کاربرگ محاسبه می شود. تا زمانی که مایکروسافت سیستم رویداد خود را ارتقاء ندهد، این کد نزدیک است. در لحظه ای که رنگ تغییر می کند محاسبه می کند، اما به محض اینکه کاربر سلولی را در ColorCells انتخاب کند یا از محدوده ColorCells خارج شود، محاسبه می شود.

     

     

    انجام عملیات با مقادیر شاخص رنگ

    توانایی برگرداندن آرایه‌ای از نمایه‌های رنگی به ما اجازه می‌دهد تا شاخص‌های رنگی محدوده سلول‌ها را آزمایش کنیم و بر اساس مقایسه آن مقادیر با یک مقدار شاخص رنگ خاص، عملیات انجام دهیم. به عنوان مثال، می‌توانیم از تابع ColorIndexOfRange در یک فرمول برای شمارش تعداد سلول‌هایی که رنگ پرشان قرمز است استفاده کنیم.

    =SUMPRODUCT(--(COLORINDEXOFRANGE(B11:B17,FALSE,1)=3))

    این تابع تعداد سلول هایی را در محدوده B11:B17 که شاخص رنگ آنها 3 یا قرمز است را برمی گرداند. به جای کدنویسی سخت 3 در فرمول، می توانید شاخص رنگ سلول دیگری را با تابع ColorIndexOfOneCell دریافت کنید و آن مقدار را به تابع ColorIndexOfRange منتقل کنید. به عنوان مثال، برای شمارش سلول‌های B11:B17 که دارای شاخص رنگی برابر با شاخص رنگ سلول H7 هستند، از فرمول استفاده می‌کنیم:

    =SUMPRODUCT(--(COLORINDEXOFRANGE(B11:B17,FALSE,1)=COLORINDEXOFONECELL(H7,FALSE,1)))

    برای شمارش رنگ‌ها، ماژول قابل دانلود modColorFunctions یک تابع مستقیم به نام CountColor ارائه می‌کند که تعداد سلول‌های یک محدوده را که دارای شاخص رنگ (از Font یا Interior) برابر با مقدار مشخصی هستند، می‌شمارد.

    تابع CountColor در زیر نشان داده شده است:

    Function CountColor(InRange As Range, ColorIndex As Long, _
        Optional OfText As Boolean = False) As Long
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CountColor
    ' This function counts the cells in InRange whose ColorIndex
    ' is equal to the ColorIndex parameter. The ColorIndex of the
    ' Font is tested if OfText is True, or the Interior property
    ' if OfText is omitted or False. If ColorIndex is not a valid
    ' ColorIndex (1 -> 56, xlColorIndexNone, xlColorIndexAutomatic)
    ' 0 is returned. If ColorIndex is 0, then xlColorIndexNone is
    ' used if OfText is Fasle or xlColorIndexAutomatic if OfText
    ' is True. This allows the caller to use a value of 0 to indicate
    ' no color for either the Interior or the Font.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim R As Range
    Dim N As Long
    Dim CI As Long
    
    If ColorIndex = 0 Then
        If OfText = False Then
            CI = xlColorIndexNone
        Else
            CI = xlColorIndexAutomatic
        End If
    Else
        CI = ColorIndex
    End If
    
    
    Application.Volatile True
    Select Case ColorIndex
        Case 0, xlColorIndexNone, xlColorIndexAutomatic
            ' OK
        Case Else
            If IsValidColorIndex(ColorIndex) = False Then
                CountColor = 0
                Exit Function
            End If
    End Select
    
    For Each R In InRange.Cells
        If OfText = True Then
            If R.Font.ColorIndex = CI Then
                N = N + 1
            End If
        Else
            If R.Interior.ColorIndex = CI Then
                N = N + 1
            End If
        End If
    Next R
    
    CountColor = N
    
    End Function

    می توانید تابع CountColor را در فرمول کاربرگ مانند شکل زیر فراخوانی کنید. با این کار تعداد گلبول های قرمز در محدوده A1:A10 محاسبه می شود.

    =COUNTCOLOR(A1:A10,3,FALSE)

    می‌توانیم از تابع ColorIndexOfRange برای بدست آوردن مجموع مقادیر در سلول‌هایی استفاده کنیم که شاخص رنگ آنها مقداری مشخص است. برای مثال، فرمول آرایه زیر مقادیر سلول‌های محدوده B11:B17 را که رنگ پر شدن آن قرمز است، جمع می‌کند.

    =SUM(B11:B17*(COLORINDEXOFRANGE(B11:B17,FALSE,1)=3))

    مانند شمارش رنگ ها، جمع کردن مقادیر بر اساس یک رنگ یک کار رایج است و ماژول modColorFunctions تابعی را برای انجام مستقیم این کار ارائه می دهد. تابع SumColor در زیر نشان داده شده است:

    Function SumColor(TestRange As Range, SumRange As Range, _
        ColorIndex As Long, Optional OfText As Boolean = False) As Variant
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' SumColor
    ' This function returns the sum of the values in SumRange where
    ' the corresponding cell in TestRange has a ColorIndex (of the
    ' Font is OfText is True, or of the Interior is OfText is omitted
    ' or False) equal to the specified ColorIndex. TestRange and
    ' SumRange may refer to the same range. An xlErrRef (#REF) error
    ' is returned if either TestRange or SumRange has more than one
    ' area or if TestRange and SumRange have differing number of
    ' either rows or columns. An xlErrValue (#VALUE) error is
    ' returned if ColorIndex is not a valid ColorIndex value.
    ' If ColorIndex is 0, xlColorIndexNone is used if OfText is
    ' False or xlColorIndexAutomatic if OfText is True. This allows
    ' the caller to specify 0 for no color applied.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim D As Double
    Dim N As Long
    Dim CI As Long
    
    Application.Volatile True
    If (TestRange.Areas.Count > 1) Or _
        (SumRange.Areas.Count > 1) Or _
        (TestRange.Rows.Count <> SumRange.Rows.Count) Or _
        (TestRange.Columns.Count <> SumRange.Columns.Count) Then
        SumColor = CVErr(xlErrRef)
        Exit Function
    End If
        
    If ColorIndex = 0 Then
        If OfText = False Then
            CI = xlColorIndexNone
        Else
            CI = xlColorIndexAutomatic
        End If
    Else
        CI = ColorIndex
    End If
    
    Select Case CI
        Case 0, xlColorIndexAutomatic, xlColorIndexNone
            ' ok
        Case Else
            If IsValidColorIndex(ColorIndex:=ColorIndex) = False Then
                SumColor = CVErr(xlErrValue)
                Exit Function
            End If
    End Select
    
    For N = 1 To TestRange.Cells.Count
        With TestRange.Cells(N)
        If OfText = True Then
            If .Font.ColorIndex = CI Then
                If IsNumeric(SumRange.Cells(N).Value) = True Then
                    D = D + SumRange.Cells(N).Value
                End If
            End If
        Else
            If .Interior.ColorIndex = CI Then
                If IsNumeric(SumRange.Cells(N).Value) = True Then
                    D = D + SumRange.Cells(N).Value
                End If
            End If
        End If
        End With
    Next N
                
    SumColor = D
    
    End Function

    تابع SumColor یک آنالوگ مبتنی بر رنگ از هر دو تابع SUM و SUMIF است. این به شما امکان می‌دهد محدوده‌های جداگانه‌ای را برای محدوده‌ای که شاخص‌های رنگ آن بررسی می‌شود و محدوده سلول‌هایی که مقادیر آن‌ها باید جمع شوند، مشخص کنید. اگر این دو محدوده یکسان باشند، تابع سلول هایی را که رنگ آنها با مقدار مشخص شده مطابقت دارد، جمع می کند. به عنوان مثال، فرمول زیر مقادیر B11:B17 که رنگ پر شدن آن قرمز است را جمع می کند.

    =SUMCOLOR(B11:B17,B11:B17,3,FALSE)

    در این فرمول، محدوده B11:B17 هم محدوده مورد آزمایش و هم محدوده برای جمع است. این محدوده ها ممکن است متفاوت باشند. به عنوان مثال، فرمول زیر شاخص رنگ سلول ها را در B11:B17 بررسی می کند و اگر شاخص رنگ آن سلول 3 باشد، مقدار مربوطه را از D11:D17 جمع می کند.

    =SUMCOLOR(B11:B17,D11:D17,3,FALSE)

    از آنجایی که تابع ColorIndexOfRange آرایه ای از مقادیر را برمی گرداند، می توان از آن در هر فرمول آرایه ای استفاده کرد. برای مثال، فرمول زیر حداقل مقداری را که رنگ پر شدن آن قرمز است از محدوده B11:B17 برمی‌گرداند:

    =MIN(IF(COLORINDEXOFRANGE(B11:B17,FALSE,1)=3,B11:B17,FALSE))

     

     

    یافتن رنگ ها

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

    Function RangeOfColor(TestRange As Range, _
            ColorIndex As Long, Optional OfText As Boolean = False) As Range

    می توانید از این تابع برای بدست آوردن محدوده ای از سلول ها با رنگ پر قرمز استفاده کنید. مثلا،

    Sub AAA()
            Dim R As Range
            Dim RR As Range
            Set RR = RangeOfColor(TestRange:=Range("A1:F20"), _
                    ColorIndex:=3, OfText:=False)
            If Not RR Is Nothing Then
                For Each R In RR
                    Debug.Print R.Address
                Next R
            Else
                Debug.Print "*** NO CELLS FOUND"
            End If
        End Sub

    با این کار در پنجره VBA Immediate آدرس سلول هایی در محدوده A1:F20 که دارای رنگ پر قرمز هستند چاپ می شود.

     

     

    توابع برای پالت و نام رنگ

    ماژول modColorFunctions شامل توابع مربوط به پالت رنگ و نام رنگ است.

    پالت رنگی پیش فرض
    این تابع آرایه ای را برمی گرداند که پالت رنگی پیش فرض اکسل است. این آرایه تغییراتی را که در Workbook.Colors ایجاد شده است منعکس نمی کند. اگر مقدار Option Base ماژول حاوی تابع DefaultColorpalette (نه ماژولی که از آن فراخوانی می شود) Option Base 0 باشد، آرایه نتیجه دارای 57 عنصر (0 تا 56) و عنصر 0 دارای مقدار 1- است. اگر مقدار Option Base Option Base 1 باشد، آرایه نتیجه دارای 56 عنصر (1 تا 56) است. در هر صورت، می توانید از یک مقدار ColorIndex معتبر برای برگرداندن مقدار رنگ RGB استفاده کنید:

    Dim N As Long
        N = 3
        Debug.Print N, Hex(DefaultColorpalette(N))

    DefaultColorNames
    این تابع آرایه‌ای از نام‌های انگلیسی آمریکایی رنگ‌ها را در پالت پیش‌فرض برمی‌گرداند (نه پالتی که با Workbook.Colors اصلاح شده است. این نام‌های رنگ‌هایی هستند که در عناصر متن نکته ابزار نوار فرمان رنگی اکسل ظاهر می‌شوند. اگر گزینه مقدار پایه ماژول حاوی تابع DefaultColorNames (نه ماژولی که از آن فراخوانی می شود) Option Base 0 است، آرایه نتیجه دارای 57 عنصر (0 تا 56) و عنصر 0 دارای مقدار UNNAMED است. اگر مقدار Option Base باشد. گزینه پایه 1 است، آرایه نتیجه دارای 56 عنصر است (1 تا 56). در هر صورت، می توانید از یک مقدار ColorIndex معتبر برای برگرداندن نام رنگ استفاده کنید. همه رنگ ها نام ندارند -- آنهایی که ندارند در نشان داده می شوند. آرایه به عنوان رشته UNNAMED.

    Dim N As Long
        N = 3
        Debug.Print N, DefaultColorNames(N)

    ColorNameOfRGB
    اگر آن رنگ در پالت پیش‌فرض برنامه وجود داشته باشد، نام رنگ انگلیسی ایالات متحده مربوط به رنگ RGB مشخص شده را برمی‌گرداند. اگر رنگ در پالت یافت نشد، تابع vbNullString را برمی‌گرداند

     

     

    توابع برای مقادیر رنگ

    ماژول modColorFunctions شامل تعدادی عملکرد برای کار با رنگ های RGB و مقادیر شاخص رنگ است.

    ColorIndexOfRGBLong
    اگر در پالت فعلی وجود داشته باشد، این مقدار Color Index مقدار رنگ مشخص شده RGB Long را برمی گرداند. در غیر این صورت 0 را برمی گرداند.

    IsColorpaletteDefault
    اگر پالت مرتبط با کتاب کار مشخص شده، پالت پیش‌فرض برنامه باشد، مقدار True را برمی‌گرداند. اگر پالت با Workbook.Colors اصلاح شده باشد، False را برمی گرداند.

    IsColorIndexDefault
    اگر رنگ مرتبط با شاخص رنگ مشخص شده با مقدار شاخص رنگ پیش‌فرض برنامه یکسان باشد، مقدار True را برمی‌گرداند. این به شما می گوید که آیا رنگ مرتبط با یک مقدار شاخص رنگ تغییر کرده است یا خیر.

    RGBComponentsFromRGBLongToVariables
    این یک مقدار RGB Long را به مقادیر تشکیل دهنده قرمز، سبز و آبی تقسیم می کند که در متغیرهای ByRef به تماس گیرنده برگردانده می شود. اگر مقدار ورودی یک رنگ RGB معتبر بود، نتیجه تابع True یا اگر مقدار ورودی یک رنگ RGB معتبر نبود، نادرست است. مثلا،

    Dim RGBColor As Long
        Dim Red As Long
        Dim Green As Long
        Dim Blue As Long
        Dim B As Boolean
        
        RGBColor = ActiveCell.Interior.Color
        B = RGBComponentsFromRGBLongToVariables(RGBColor, Red, Green, Blue)
        If B = True Then
            Debug.Print "Red: " & Red, "Green: " & Green, "Blue: " & Blue
        Else
            Debug.Print "Invalid value in RGBColor"
        End If

    RGB ComponentsFromRGBLong
    این یک مقدار رنگ RGB Long را به اجزای قرمز، سبز و آبی تقسیم می کند و آنها را به عنوان آرایه ای از Longs برمی گرداند

    Arr(1) = Red
        Arr(2) = Green
        Arr(3) = Blue
    
     

     

     

    نمایش دیالوگ انتخابگر رنگ

    ماژول modColorFunctions حاوی تابعی به نام ChooseColorDialog است که یک گفتگوی انتخابگر رنگ ویندوز را نمایش می دهد و مقدار رنگ RGB Long را برمی گرداند. اگر کاربر گفتگو را لغو کند، نتیجه -1 است. مثلا،

    Dim RGBColor As Long
        Dim Default As Long
        Default = RGB(255, 0, 255) 'default to purple
        RGBColor = ChooseColorDialog(DefaultColor:=Default)
        If RGBColor < 0 Then
            Debug.Print "*** USER CANCELLED"
        Else
            Debug.Print "Choice: " & Hex(RGBColor)
        End If
    
     

     

    تعیین نزدیکترین رنگ در پالت

    در این بخش، از یک تابع VBA برای برگرداندن مقدار ColorIndex رنگ در پالتی که نزدیک‌ترین مقدار رنگ RGB Long است، استفاده می‌کنیم. کل مفهوم "نزدیک ترین" رنگ تا حدودی ذهنی است. دو نفر نیازی به توافق ندارند که آیا یک رنگ در واقع به رنگی نزدیکتر از رنگ دیگر است. روش مورد استفاده در اینجا هر رنگ RGB را به عنوان یک مکان فضایی در یک فضای 3 بعدی در نظر می گیرد که در آن محورها اجزای قرمز، سبز و آبی با مقدار RGB Long هستند. کد، ColorIndex رنگی را پیدا می کند که کمترین فاصله را در این فاصله بین مقدار Colors (ColorIndex) و مقدار RGB Long برای آزمایش دارد. فاصله با فاصله فیثاغورثی ساده تعیین می شود، اما برای سرعت محاسبه، جذر را از محاسبه حذف می کنیم.

    Function ClosestColor(RGBLong As Long) As Long
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ClosestColor
    ' This function returns ColorIndex of the color that is "closest" to the
    ' specified RGBLong value. "Closest" is taken in the geometrical sense, the
    ' distance between two colors in a 3-dimensional space with axes of Red,
    ' Green, and Blue values. That is, a color is identified spatially by
    ' the values of the Red, Green, and Blue components. The distances between
    ' the spatial location of RGBLong and each Color of the palette is computed
    ' and the ColorIndex that minimizes this distance is returned. The distance
    ' between RGBLong and each Colors(ColorIndex) value is computed by simple
    ' Pythagorean distance:
    '       Dist = ( (R1-R2)^2  + (G1-G2)^2 + (B1-B2)^2 ) ^ (1/2)
    ' where R1, G1, and B1 are the compontents of RGBLong and R2, G2, and B2 are
    ' the components of each Color(ColorIndex) value.
    ' We can save some processing by omitting the square root from the calculations.
    ' Note that the entire concept of a "closest" color is rather subjective and there
    ' are other methods of computing the "closeness" of two colors.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim MinDist As Double   ' running minimum distance 
    Dim MinCI As Double     ' ColorIndex corresponding to MinDist 
    Dim CI As Long          ' ColorIndex loop variable 
    Dim DistCI As Double    ' Distance between each CI and RGBLong 
    
    
    ' values from RGBLong 
    Dim RedTest As Long
    Dim GreenTest As Long
    Dim BlueTest As Long
    
    ' value from each CI in palette 
    Dim RedCI As Long
    Dim GreenCI As Long
    Dim BlueCI As Long
    
    ' ensure we have a valid RGB 
    If IsValidRGBLong(RGBLong) = False Then
        ClosestColor = 0
        Exit Function
    End If
    
    ' init min distance = maximum possible distance. 
    MinDist = 195075 ' 255^2 + 255^2 + 255^2. omit the square root.
    
    ' color components of RGBLong 
    RGBComponentsFromRGBLongToVariables RGBLong, RedTest, GreenTest, BlueTest
    
    For CI = 1 To 56
        RGBComponentsFromRGBLongToVariables ThisWorkbook.Colors(CI), RedCI, GreenCI, BlueCI
        ' compute the distance. we omit the square root operations since it doesn't affect relationships. 
        DistCI = ((RedTest - RedCI) ^ 2 + (GreenTest - GreenCI) ^ 2 + (BlueTest - BlueCI) ^ 2)
        If DistCI < MinDist Then
            ' distance is less than current minimum. set save variables. 
            MinDist = DistCI
            MinCI = CI
        End If
    Next CI
    
    ClosestColor = MinCI
    
    End Function

     

    نظرات ارسال شده ارسال نظر جدید
    برای تبادل نظر، می بایست در سایت وارد شوید

    ورود به سایت
تماس سبد خرید بالا