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]

OK,
Alter the values in Array as you want them....

Sub ColorByMonth()
    Dim rCell As Range
    Dim myColor As Integer
    Application.ScreenUpdating = False
    Application.Calculate
    On Error GoTo Xit
    For Each rCell In Range("j2:j" & Range("j65536").End(xlUp).Row)
        If Not IsEmpty(rCell) Then
        Select Case Year(rCell)
            Case 2006: myColor = Array(36,42,39,1,2,3,4,5,6,7,8,9)
            Case Else : myColor = Array(12,13,14,15,16,17,18,19,20,21,22,23)
        End Select
        rCell.Offset(,1).Interior.ColorIndex=Clng(Application.Match(CStr(Month(rCell)-1),myColor,0))
        Else
            rCell.Offset(0, 1).Interior.ColorIndex = 0
        End If
    Next

 

[pbt]

It was late last night, just got back on this.

I tried the following:

Sub ColorByMonthTest()
    Dim rCell As Range
    Dim myColor As Integer
    Application.ScreenUpdating = False
    Application.Calculate
    On Error GoTo Xit
    For Each rCell In Range("j2:j" & Range("j65536").End(xlUp).Row)
        If Not IsEmpty(rCell) Then
        Select Case Year(rCell)
            Case 2006: myColor = Array(36, 42, 39, 48, 4, 45, 27, 38, 28, 44, 18, 43)
            Case Else: myColor = Array(43, 18, 44, 28, 38, 27, 45, 4, 48, 39, 42, 36)
        End Select
        rCell.Offset(, 1).Interior.ColorIndex = CLng(Application.Match(CStr(Month(rCell) - 1), myColor, 0))
        Else
            rCell.Offset(0, 1).Interior.ColorIndex = 0
        End If
    Next
Xit:
Application.CalculateFull
Application.ScreenUpdating = True

End Sub

This did not do anything at all. I changed the date in J2 to a 2007 date and ran the macro ~ nothing.

Stepped through the code and it jumps after reading this line:

 Case 2006: myColor = Array(36, 42, 39, 48, 4, 45, 27, 38, 28, 44, 18, 43)

To this line:

Application.CalculateFull

It seems to being encountering an error in the above line and exiting the procedure.

Any ideas from anybody. Just checked the time zone for Jindon it's 1:00 in the morning there, probaly sleeping.

Thanks
h.h.

 

[jindon]

It can't be...
I guess your code is in Standard module.
You need to add the following code onto sheet module

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("j2",Range("j" & Rows.Counr).End(xlup))) Is Nothing Then
Application.EnableEvents = False
ColorByMonthTest
Application.EnableEvents = True
End If

 

[pbt]

Thanks Jindon,

I inserted your code in the sheet module with the spelling correction to the word .count. It still does the same thing as stated above ~ some kind of error.

Thanks for your efforts on the latest suggestion, but this morning while you were off line, I played around with your first reply now that I understand your explanation on this line:

myColor = myColor + Year(Date) - Year(rCell

This is what I now have:

Sub ColorByMonth()
    Dim rCell As Range
    Dim myColor As Integer
    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: myColor = 4
            Case 2: myColor = 8
            Case 3: myColor = 14
.............................
.............................
          Case 12: myColor = 44
        If rCell.Value = ("") Then
    rCell.Offset(0, 1).Interior.ColorIndex = 0
End If
        End Select
        myColor = myColor - Year(Date) + Year(rCell)
     rCell.Offset(, 1).Interior.ColorIndex = myColor
    Next
For Each rCell In Range("P2:P" & Range("P65536").End(xlUp).Row)
        Select Case Month(rCell)
             Case 1: myColor = 4
            Case 2: myColor = 8
            Case 3: myColor = 14
..........................
..........................
           Case 12: myColor = 44
        If rCell.Value = ("") Then
    rCell.Offset(0, 1).Interior.ColorIndex = 0
End If
        End Select
        myColor = myColor + Year(Date) - Year(rCell)
     rCell.Offset(, 1).Interior.ColorIndex = myColor
    Next
For Each rCell In Range("U2:U" & Range("U65536").End(xlUp).Row)
    
        Select Case Month(rCell)
            Case 1: myColor = 4
            Case 2: myColor = 8
            Case 3: myColor = 14
.........................
.........................
            Case 12: myColor = 44
        If rCell.Value = ("") Then
    rCell.Offset(0, 1).Interior.ColorIndex = 0
End If
        End Select
        myColor = myColor + Year(Date) - Year(rCell)
     rCell.Offset(, 1).Interior.ColorIndex = myColor
    Next
Xit:
Application.CalculateFull
Application.ScreenUpdating = True

End Sub

This works fine for cloumn "J" but does not change anything in columns "P & U"

This is a portion of the worksheet

SCSP 2006 FORECAST test 1.xls
	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	SCHEDS&N	SCHED. LHFINISH	%45LATH+ OPTIONFORECAST	45% BILLED	%45LATH+ OPTIONACTUAL	Invoice#	PAID	SCHEDSTFINISH	50%FINISHFORECAST	50%BILLED	50%FINISHACTUAL	Invoice#	PAID	5%Retention
2	01/13/07	1/16/07	$5,878.20			10122		01/29/07	$5,488.00			10454	3/30/06	$548.80
3	12/13/06	12/16/06	$5,402.20			10171		12/29/06	$5,488.00			10284
4	12/13/06	12/16/06	$5,511.20			10114		12/29/06	$4,688.00			10279	1/15/06	$468.80
5	11/13/06	11/16/06	$3,176.55			10042		11/29/06	$3,529.50			10298
6	12/13/06	12/16/06	$5,983.00			10113		12/29/06	$4,860.00			10277
7	12/02/06	12/5/06	$5,330.85			10115		12/18/06	$5,696.50			10276
8	11/28/05	12/1/05	$4,000.05			10118		12/14/05	$4,444.50			10285
WEBB

The user will do all date changes in column"I" and "J, P, & U" dates will change acording to the formulas. And from the color of the cells I have UDF's on another worksheet that will Sum the dollars.

I hope this helps

h.h.

 

[jindon]

OK

Let's make it sure that

you want to color the cells in col
K, Q and V accroding to the value in the previous column

is it correct?

 

[pbt]

Yes that is correct. That is why the .offset(0,1)

EDIT:
My mistake ~ Column "U" is hard entered not changed by formula

 

[jindon]

Yes that is correct. That is why the .offset(0,1)

EDIT:
My mistake ~ Column "U" is hard entered not changed by formula

Ok, but you never mentioned multiple columns to work with.

You need worksheet_Calculate event code as well.
Paste the whole code onto sheet module and select other sheet once and come back to the sheet in question in order to activate Worksheet_Activate Event

Private myColor2006(), myColorElse()

Private Sub Worksheet_Activate()
myColor2006 = Array(YourArrangeFor2006)
myColorElse = Array(YourArrangeForElse)
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.ColoIndex = myColor2006(Month(.Value)-1)
     Else
         .Offset(,1).Interior.ColorIndex = 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
                  r.Offset(,1).Interior.ColoeIndex = myColor2006(Month(r.Value)-1)
              Else
                  r.Offset(,1).Interior.ColoIndex = myColorElse(Month(r.Value)-1)
           End If
         End If
     Next
Next
Application.EnableEvents=True
End Sub

 

[pbt]

My apologies about the other columns.

Pasted the code in the sheet module. This line was red before I click another sheet.

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

After clicking another sheet and coming back to the sheet in question, I ran the code, colums Q & V still did not change color. Column K does change.

h.h.

 

[jindon]

Oops typo

it should read Interior.ColorIndex..

The code should:

if change made to column U by entering the value, its adjacent cell should change the color

if teh sheet calucualte in any cell, it will loop though the columns and change the colors.

 

[pbt]

Jindon, please forgive me I am still a novice at this.

I was studying your last post to see if I can figure this out. Am I suppose to insert an Array in the area that you put parentheses, and as you suggested in an earlier reply??

myColor2006 = Array(YourArrangeFor2006) 
myColorElse = Array(YourArrangeForElse)

Also I still have my code in a standard module *** previously posted

This is what I now have:

Sub ColorByMonth() 
    Dim rCell As Range 
    Dim myColor As Integer 
    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: myColor = 4 
            Case 2: myColor = 8 
            Case 3: myColor = 14 
.............................so on and so forth

Please let me knowd if I am on the right track.

Thanks
h.h.