作者 主題: Good VBA coding Example 寫macro 讓Excel 的儲存格使用  (閱讀 8688 次)

0 會員 與 1 訪客 正在閱讀本文。

小徒兒

  • 鑽研的研究生
  • *****
  • 文章數: 622
    • 檢視個人資料
insert/define/name add "ciRed" value =3

寫在cell 裡
=IF(ColorIndex(A1)=ciRed,"Warning!","")

代碼: [選擇]
Code Sample(s)

--------------------------------------------------------------------------------

'---------------------------------------------------------------------
' ColorIndex Function
'---------------------------------------------------------------------
' Function:    Returns the colorindex of the supplied range
' Synopsis:    Initially, gets a colorindex value for black and white
'              from the activeworkbook colour palette
'              Then works through each cell in  the supplied range and
'              determines the colorindex, and adds to array
'              Finishes by returning acumulated array
' Variations:  Determines cell colour (interior) or text colour (font)
'              Default is cell colour
' Constraints: Does not count colours set by conditional formatting
'---------------------------------------------------------------------
' Author:      Bob Phillips
'              Additions for ranges suggested by Harlan Grove
'---------------------------------------------------------------------


'---------------------------------------------------------------------
Function ColorIndex(rng As Range, _
                    Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant

    If rng.Areas.Count > 1 Then
        ColorIndex = CVErr(xlErrValue)
        Exit Function
    End If

    iWhite = WhiteColorindex(rng.Worksheet.Parent)
    iBlack = BlackColorindex(rng.Worksheet.Parent)

    If rng.Cells.Count = 1 Then
        If text Then
            aryColours = DecodeColorIndex(rng, True, iBlack)
        Else
            aryColours = DecodeColorIndex(rng, False, iWhite)
        End If

    Else
        aryColours = rng.Value
        i = 0

        For Each row In rng.Rows
            i = i + 1
            j = 0

            For Each cell In row.Cells
                j = j + 1

                If text Then
                    aryColours(i, j) = _
                      DecodeColorIndex(cell,True,iBlack)
                Else
                    aryColours(i, j) = _
                      DecodeColorIndex(cell,False,iWhite)
                End If

            Next cell

        Next row

    End If

    ColorIndex = aryColours

End Function

'---------------------------------------------------------------------
Private Function WhiteColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
    WhiteColorindex = 0
    For iPalette = 1 To 56
        If oWB.Colors(iPalette) = &HFFFFFF Then
            WhiteColorindex = iPalette
            Exit Function
        End If
    Next iPalette
End Function

'---------------------------------------------------------------------
Private Function BlackColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
    BlackColorindex = 0
    For iPalette = 1 To 56
        If oWB.Colors(iPalette) = &H0 Then
            BlackColorindex = iPalette
            Exit Function
        End If
    Next iPalette
End Function

'---------------------------------------------------------------------
Private Function DecodeColorIndex(rng As Range, _
                                  text As Boolean, _
                                  idx As Long)
'---------------------------------------------------------------------
Dim iColor As Long
    If text Then
        iColor = rng.font.ColorIndex
    Else
        iColor = rng.Interior.ColorIndex
    End If
    If iColor < 0 Then
        iColor = idx
    End If
    DecodeColorIndex = iColor
End Function

'---------------------------------------------------------------------
' End of ColorIndex Function
'---------------------------------------------------------------------


« 上次編輯: 2008-05-30 10:59 由 小徒兒 »

小徒兒

  • 鑽研的研究生
  • *****
  • 文章數: 622
    • 檢視個人資料
vba code 傳入Range 須以 byval 不能用 byref
« 回覆 #1 於: 2008-05-30 11:22 »


代碼: [選擇]
Sub ColorizeIssuesAndActions()
' Purpose: underline Issue / Action combination by colorization grey / white
' History: 07.10.2004 pza, created
'          10.11.2004 pza, modified: Handle new Issues (without IssueNo)

'<Public Constants>
DATA_SHEET = 1          'No. data sheet
COL_ISSUENO = "A"        'Column containing status
COL_REF = "C"              'Reference column to stop when empty
first_datarow = 3       'No. of first Row containing data
COLOR_INDEX = 15   'Cell.ColorIndex status 'In Progress'
'</Public Constants>

Dim vIssueNo As Variant
Dim vRef As Variant
Dim iColorized As Integer
Dim i As Integer

Worksheets(DATA_SHEET).Select
i = 0
iColorized = False
vRef = Worksheets(DATA_SHEET).Range(COL_REF & CStr(first_datarow)).Value
vIssueNo = Worksheets(DATA_SHEET).Range(COL_ISSUENO & CStr(first_datarow)).Value
intfirstline = first_datarow

While Not vRef = ""
   
   
    vIssueNoNext = Worksheets(DATA_SHEET).Range(COL_ISSUENO & CStr(first_datarow + i + 1)).Value
   
    'use vIssueNoNext & vIssueNo to judge wether it is the same Issue
   
    If vIssueNoNext <> vIssueNo Or vIssueNoNext = "" Then
   
    'This portion do the codes for another new isssue lines thus change color
    'use flag to catch the portion
    'use intfirstline to know the first line
    'use intTotallines to know how much should be select
     
            If intfirstline > first_datarow Then
                Range(Cells(intfirstline, 1), Cells(intfirstline + intTotallines, 14)).Select
               
                Dim thisParameterrange As Range
               
                Set thisParameterrange = Selection
               
                borderThis thisParameterrange
             
            End If
           
    intfirstline = first_datarow + i
    intTotallines = 1
    Debug.Print "Issue FirstLine:" & intfirstline
        'Change Color for this Issue / Action
       
       
        If iColorized = True Then
           Range(Cells(first_datarow + i, 1), Cells(first_datarow + i, 14)).Select
             Range(Cells(first_datarow + i, 1), Cells(first_datarow + i, 14)).Select
                         

            With Selection.Interior
            .ColorIndex = COLOR_INDEX
            .Pattern = xlSolid
            End With
            iColorized = False
        Else
             Range(Cells(first_datarow + i, 1), Cells(first_datarow + i, 14)).Select
            Selection.Interior.ColorIndex = xlNone
            iColorized = True
        End If
   
   
    Else
       
    intTotallines = intTotallines + 1
       
        'Keep Color for this Issue / Action
        If iColorized = True Then
             Range(Cells(first_datarow + i, 1), Cells(first_datarow + i, 14)).Select
 
            With thisselection.Interior
            .ColorIndex = COLOR_INDEX
            .Pattern = xlSolid
            End With
            iColorized = True
        Else
            Range(Cells(first_datarow + i, 1), Cells(first_datarow + i, 14)).Select
             With Selection.Interior
                .ColorIndex = xlNone
             End With
            'thisselection.Interior.ColorIndex = xlNone
            iColorized = False
        End If
       
    End If
   
    i = i + 1
   
    'use vIssueNo to judge whether to the new issue
    vIssueNo = Worksheets(DATA_SHEET).Range(COL_ISSUENO & CStr(first_datarow + i)).Value
   
    vRef = Worksheets(DATA_SHEET).Range(COL_REF & CStr(first_datarow + i)).Value
Wend
End Sub

代碼: [選擇]
Sub borderThis(ByVal thisselection As Range)



                    thisselection.Borders(xlDiagonalDown).LineStyle = xlNone
                    thisselection.Borders(xlDiagonalUp).LineStyle = xlNone
                    With thisselection.Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With thisselection.Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With thisselection.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With thisselection.Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With thisselection.Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With thisselection.Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
           


End Sub

« 上次編輯: 2008-05-30 11:25 由 小徒兒 »