macro change cell color on single click

[djangounchained]

i had a code which changes cell color on single click and create new sheet on running macro with filtered results only , but i want to edit this macro for each run it should create new sheets with serial number 1 2 .... etc

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

please help thanks and regards

 

[pbornemeier]

The code you posted returns an array that contains the color index of each cell in the range provided as an input variable. It does no color changing, sheet creating or filtering.

it does not

... change cell color on single click and create new sheet on running macro with filtered results only

You said you want

" to edit this macro for each run it should create new sheets with serial number 1 2 .... etc

The code you provided will only run 1 time through, so do you want the macro to search existing sheets for the last number used as a sheet name then create a new worksheet with the next number?
What data to you want on the new sheet(s)?

This code will add serialized worksheets:

Sub AddNewSerializedSheet()
    'Find the worksheet that matches the pattern below with the highest serial number.
    '  Create a worksheet with the next highest serial number
    
    Dim sPattern As String
    Dim lSheetIndex As Long
    Dim wks As Worksheet
    Dim lPatternMax As Long
    Dim sSerial As String
    
    sPattern = "####"
    
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name Like sPattern Then
            If CLng(wks.Name) > lPatternMax Then lPatternMax = CLng(wks.Name)
        End If
    Next
    
    sSerial = Right("000" & lPatternMax + 1, 4)
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sSerial 'After last

End Sub