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]

Thank you for your patience on this

Just in case the code that I am working with got lost in all these post, here is what I have:

Private myColor2006(), myColorElse()

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
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 = CLng(myColor2006(Month(.Value) - 1))
     Else
         .Offset(, 1).Interior.ColorIndex = CLng(myColorElse(Month(.Value) - 1))
     End If
     Application.EnableEvents = True
End With
End Sub
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
              MsgBox CLng(myColor2006(Month(r.Value) - 1))

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

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

In the sheet module

h.h.

 

[jindon]

Replace the sheet module with the following code.

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
End With
     Application.EnableEvents = False
     test
     Application.EnableEvents = True
End Sub

Private Sub Worksheet_Calculate()
Application.EnableEvents = False
test
Application.EnableEvents = True
End Sub

And put this code in the Standard module

Sub test()
Dim r As Range, myCol, i As Integer
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
              Select Case Month(r.Value)
                   Case 1 : myColor = 7
                   Case 2 : myColor = 13
                   Case 3 : myColor = 16
                   Case 4 : myColor = 19
                   Case 5 : myColor = 23
                   Case 6 : myColor = 27
                   Case 7 : myColor = 30
                   Case 8 : myColor = 35
                   Case 9 : myColor = 39
                   Case 10 : myColor = 41
                   Case 11 : myColor = 44
                   Case 12 : myColor = 47
               End Select
               If IsEmpty(myColor) then 
                      MsgBox("something wrong in " & r.address)
                      Exit Sub
               End If
               If Year(r.Value) <> 2006 Then myColor = MyColor + 1
               r.Offset(,1).Interior.ColorIndex = myColor
               myColor = Empty
         End If
      Next
Next
End Sub

 

[pbt]

Jindon,

I don't know if this might help the situation, in the date driver columns, I have put in dates of the year 2005 which in column "K" will change to the appropiate color.

That is, for Jan 2006 = Color index 7, your code of (Else willl pick 8 for 2007, and for 2005 it automatically pick 6.

This will happen for every month: that is 2006 is the center number, 2007 is one greater & 2005 is one less.
***********************************************************
While I was typing this, you posted your next reply:

(I check by opening another window in Explorer)

Before I try your new post, do you think that what I say above will have any affect.

h.h.

 

[jindon]

hurry,

I don't understand why you are getting error with the first code to be honest.

But the 1st priority is to solve your problem...

I guess something to do with cell format, but not sure...

 

[pbt]

Jindon

First of all I wasn't getting an error. It was only changeing the colors in the first column, not the other two.

I went ahead and tried your last post.

Got a : Object doesn't support this property or method Error
This line highlighted:

r.Offset(, 1).Interior.ColoIndex = myColor

from the Standard module

 

[jindon]

Sorry typo

Should be ColorIndex instead of ColoIndex

 

[jindon]

Jindon

First of all I wasn't getting an error. It was only changeing the colors in the first column, not the other two.

OK, then all we should do to make sure it loop through all the columns.

But if the second code works for you, it doesn't need to...

 

[pbt]

I see light at the end of the tunnel

It works ~ all columns change color!

The only problem I have is, because I put the year of 2005 in the worksheet, those cells pick up the 2006 colors.
Edit:
2005 is picking up 2007 colors

I think the code needs another "Else" statement, (correct me if I'm worong)
****************************************
This just popped into my head.

Is it possible to make this robust. Meaning, instead of refering to the year 2006 as "the center Color Index" that it will refer to the current Year as the "center Color Index"

EDIT:
During 2007, all entries for 2005 willbe deleted

The reason I ask this is, the user may forget to clear out old data in the next "input year" and now we are in the Year 2007 and the sheet may have data from 2006 & 2007 & 2008, that needs to be there.

So what I can see is to go into VBA editor and change reference to 2006 to 2007. Something I don't want the user to do.

h.h.
[/b]

 

[jindon]

If you want to change the ColorIndex for each year differently,
you need to create the array for that.

But, I saw your ColorIndex is increased by 1 for each month of each year,
so

If you make it easier,

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

Like I did it at the first code(changed already)

that means:
If the Month(r.Value) = 1 Then 7
and
7 + 2006 - Year(r.Value) means
7 + 2006 - 2006 = 7 (when year(r) = 2006)
7 + 2007 - 2006 = 8 (when year(r) = 2007)

 

[pbt]

I will explore this a little further tomorrow.

Right now it is 11:30 PM and my wife is P****d. She went to bed and I think maybe I should too.

I'll let you know what I come up with.

Thanks for all your help so far.

h.h,