Group sheets by color

I am trying to use the group by sheets color macro by cpearson     http://www.cpearson.com/excel/sortws.aspx 

I seem to not be passing the variables correctly though

Here is what I pass
x = 136
 GroupSheetsByColor(1, x,errortext,ColorArray(2,3,6))

Open in new window


and here is the full function

Public Function GroupSheetsByColor(ByVal FirstToSort As Long, ByVal LastToSort As Long, _
    ByRef errortext As String, ColorArray() As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GroupSheetsByColor
' This groups worksheets by color. The order of the colors
' to group by must be the ColorIndex values stored in
' ColorsArray.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim WB As Workbook
Dim B As Boolean
Dim N1 As Long
Dim N2 As Long
Dim N3 As Long
Dim CI1 As Long
Dim CI2 As Long
Dim CArray As Variant

Dim CNdx1 As Long
Dim Cndx2 As Long

Const MIN_COLOR_INDEX = 1
Const MAX_COLOR_INDEX = 56


If IsArrayAllocated(ColorArray) = False Then
    errortext = "ColorArray is not a valid, allocated array."
    GroupSheetsByColor = False
    Exit Function
End If


Set WB = Worksheets.Parent
errortext = vbNullString


''''''''''''''''''''''''''''''''''''''
' Setup ColorIndex array
'''''''''''''''''''''''''''''''''''''
If IsMissing(ColorArray) = False Then
    If IsArray(ColorArray) = False Then
        errortext = "ColorArray is not an array"
        GroupSheetsByColor = False
        Exit Function
    End If
Else
    ''''''''''''''''''''''''''''''''''''''
    ' Ensure all color indexes are valid.
    ''''''''''''''''''''''''''''''''''''''
    For N1 = LBound(ColorArray) To UBound(ColorArray)
        If (ColorArray(N1) > MAX_COLOR_INDEX) Or (ColorArray(N1) < MIN_COLOR_INDEX) Then
            errortext = "Invalid ColorIndex in ColorArray"
            GroupSheetsByColor = False
            Exit Function
        End If
    Next N1
End If

Set WB = Worksheets.Parent

errortext = vbNullString

If (FirstToSort <= 0) And (LastToSort <= 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
End If

B = TestFirstLastSort(FirstToSort, LastToSort, errortext)
If B = False Then
    GroupSheetsByColor = False
    Exit Function
End If

For N1 = FirstToSort To LastToSort
    If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(LBound(ColorArray)) Then
        WB.Worksheets(N1).Move before:=WB.Worksheets(1)
        Exit For
    End If
Next N1
N3 = 1
For N2 = LBound(ColorArray) To UBound(ColorArray)
    For N1 = 2 To LastToSort
        If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(N2) Then
            WB.Worksheets(N1).Move after:=WB.Worksheets(N3)
            N3 = N3 + 1
        End If
        
    Next N1
Next N2

GroupSheetsByColor = True

End Function

Open in new window


Thanks,
Montrof
LVL 1
montrofAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

FamousMortimerCommented:
Hi Montrof,

You will need to declare and popualte the color array before sending it to the function

Dim ColorArray() As Long
    ColorArray = Array(2, 3, 6)
GroupSheetsByColor 1, x, errortext, ColorArray

Open in new window

0
montrofAuthor Commented:
I get an error at  ColorArray = Array(3, 4, 6) saying type mismatch

montrof
0
FamousMortimerCommented:
My apologies.  I did not test it.

try this

    Dim ColorArray(2) As Long
    ColorArray(0) = 2: ColorArray(1) = 3: ColorArray(2) = 6
    GroupSheetsByColor 1, x, errortext, ColorArray

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
montrofAuthor Commented:
Perfect Thank you
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Applications

From novice to tech pro — start learning today.