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.

 

[jindon]

OOPS,

Sorrrrryyyyy

I'm an idiot.

The code has been edited.

After you paste the code, I need you to fill up both array as you want

e.g.
myColor2006 = Array(colorindex for Jan, for Feb, for march,,,,,)

 

[pbt]

I seen your Edit after I posted and did the change.

I filled in the Array with the numbers I want. Gets hung up on my UDF's because I have not changed them to my new index numbers. (I think that is the problem)

Sample: SumByColor(WEBB!$K2:$@000,3,FALSE)~~~ "3" needs to change to new number

I will try to update the UDF's tomorrow or Monday. Right now it's 12:30 in the morning and I'm burnt out.

Please keep watching this post, I may have other issues.

And thank you very much for the help that you have given so far.

h.h.

 

[jindon]

OK

I will be busy tomorrow(Mon), but come back on Tue..

Talk to you soon..

 

[pbt]

Got everything updated.

When I click on the worksheet (the one with the Worksheet_Activate code)
I get a Compile error: Expected End Sub.

This line is highlighted yellow:

Private Sub Worksheet_Activate()

And the cursor is between these two lines:

myColorElse = Array(8, 14, 17, 20, 24, 28, 31, 36, 40, 42, 45, 48)

Private Sub Worksheet_Change(ByVal Target As Range)

Do I need an End Sub there? I put one in just to see what happens. Ran the macro and it showed the hour glass for the longest time, so I hit ESC to get out.

The first "End If" line in my UDF was highlighted.

Function SumByColor(InRange As Range, WhatColorIndex As Integer, _
    Optional OfText As Boolean = False) As Double
Dim Rng As Range
Dim OK As Boolean

For Each Rng In InRange.Cells
    If OfText = True Then
        OK = (Rng.Font.ColorIndex = WhatColorIndex)
    Else
        OK = (Rng.Interior.ColorIndex = WhatColorIndex)
    End If
    If OK And IsNumeric(Rng.Value) Then
        SumByColor = SumByColor + Rng.Value
    End If
Next Rng

End Function

h.h.

 

[jindon]

Yes, I missed that one and the code had modified...

 

[pbt]

This might get a little lengthy, getting a solution to this. Your days are my nights because of the time zones.

Anyway, I went back and double checked my code and made all the modifications

The code now runs through without any hang-ups. But the only row that changes color is the first (K), the other two do not.

Can't figure it out

h.h.

 

[pbt]

Just bumping,(since I see Jindon is on line)

Hopeing for some help

h.h.

 

[jindon]

Good morning harry

OK, what I wnat you to do is Step debugging(easy)

I edited the code(added 2 "Stop")

when you change the date, it runs and pause at eh line of "Stop",
then the code will execute line by line as you press F8.

Please check, if the code is running correctly or not....

 

[pbt]

First of all, thank you for comming back on this.

On your reply, I don't know what you mean with the line:

I edited the code(added 2 "Stop")

what i did was step through (F8)

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)

No Problems

Private Sub Worksheet_Change(ByVal Target As Range)

Does not let me step through (F8), Makes a beeping noise.

Stepping through:

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.ColoeIndex = Application.Match(Month(r.Value) - 1, myColor2006, 0)
              Else
              r.Offset(, 1).Interior.ColoIndex = Application.Match(Month(r.Value) - 1, myColorElse, 0)
           End If
         End If
     Next
Next
Application.EnableEvents = True
End Sub

Skips over this line:

r.Offset(, 1).Interior.ColoeIndex = Application.Match(Month(r.Value) - 1, myColor2006, 0)

Then when it hits this line:

 r.Offset(, 1).Interior.ColoIndex = Application.Match(Month(r.Value) - 1, myColorElse, 0)

It gives me a Run-time error "438": Object doesn't support this property or method.

h.h.

 

[jindon]

Oh

You are using old code,,,,

Can you copy the code again which is changed as

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