Expand on current VBA procedure

[pbt]

Hi folks,

I have the follwing code that will turn the ajoining cell to a particular color based on the Month of a date that is formated 1/12/06.

I need to expand on this code so it will also look at the Year. This spreedsheet will run into the next year so just looking at the month will not do. Of course I would change the color index for the next year to something else.

Sub ColorByMonth()
    Dim rCell As Range
    Application.ScreenUpdating = False
    Application.Calculate
    On Error GoTo Xit
    For Each rCell In Range("j2:j" & Range("j65536").End(xlUp).Row)
        Select Case Month(rCell)
            Case 1
                rCell.Offset(0, 1).Interior.ColorIndex = 36
            Case 2
                rCell.Offset(0, 1).Interior.ColorIndex = 42
            Case 3
                rCell.Offset(0, 1).Interior.ColorIndex = 39

This continues for all twelve months (Case 12)

Any help would be greatly appreciated.

Thanks
h.h.

 

[pbt]

My apoligies, after I posted I realized I had the wrong file open ray:

Private Sub Worksheet_Activate()
myColor2006 = Array(7, 13, 16, 19, 23, 27, 30, 35, 39, 41, 44, 47)
myColorElse = Array(8, 14, 17, 20, 24, 28, 31, 36, 40, 42, 45, 48)
End Sub

steps through with no problems.

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
     If .Count > 1 Then Exit Sub
     If Intersect(.Cells, Range("u:u")) Is Nothing Then Exit Sub
     If .Row > 1 Then Exit Sub
     If Not IsDate(.Cells) Then Exit Sub
     Application.EnableEvents = False
     If Year(.Value) = 2006 Then
         .Offset(, 1).Interior.ColorIndex = myColor2006(Month(.Value) - 1)
     Else
         .Offset(, 1).Interior.ColorrIndex = myColorElse(Month(.Value) - 1)
     End If
     Application.EnableEvents = True
End With
End Sub

Unable to step through (probaly normal ??)

Private Sub Worksheet_Calculate()
Dim r As Range, myCol, i As Integer
Application.EnableEvents = False
myCol = Array("j", "p", "u")
For i = 0 To UBound(myCol)
     For Each r In Range(myCol(i) & "2", Range(myCol(i) & Rows.Count).End(xlUp))
          If IsDate(r.Value) Then
              If Year(r.Value) = 2006 Then
                  r.Offset(, 1).Interior.ColorIndex = myColor2006(Month(r.Value) - 1)
              Else
                  r.Offset(, 1).Interior.ColorIndex = myColorElse(Month(r.Value) - 1)

           End If
         End If
     Next
Next
Application.EnableEvents = True
End Sub

Skips over this line:

 r.Offset(, 1).Interior.ColorIndex = myColor2006(Month(r.Value) - 1)

On this lin I get: Run-time error '13': Type mismatch

r.Offset(, 1).Interior.ColorIndex = myColorElse(Month(r.Value) - 1)

h.h.

 

[jindon]

OK

Can you change these two lines like

ColorIndex = Clng(myColor2006(Month(r.Value) -1))

ColorIndex = Clng(myColorElse(Month(r.Value) -1))

 

[pbt]

I changed it in the:

Private Sub Worksheet_Change(ByVal Target As Range)

AND

Private Sub Worksheet_Calculate()

Procedure ~ still the same thing ~ only the first column changes.

h.h.

 

[jindon]

No errors?

 

[pbt]

Stepped through with the:

 CLng(myColor2006(Month(r.Value) - 1))

change;

Got a "type mismatch" error on the Worksheet_Calculate Procedure

h.h.

 

[jindon]

Can you add following on eline to check the value from Month function?

MsgBox Month(r.Value)

above the line that you get an error.

 

[pbt]

I got a number one (1)

 

[jindon]

OK

Then

msgbox clng(mycolor2006(Month(r.value)-1))

please?

 

[pbt]

I get a "type mis-match error with that

h.h.

 

[jindon]

didi you delect other sheet before you run the code?

seems both array is empty....

And make sure that you have

Private MyColor2006, MyColorElse

on the top of the sheet module..