djangounchained
New Member
- Joined
- Jan 19, 2013
- Messages
- 25
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
please help thanks and regards
Code:
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
Last edited by a moderator: