I am trying to create a calendar that will automatically color and
shade the cells according to certain conditions. I can't use
Conditional Formatting because if I try to copy and paste items from
the calendar, it copies the manual formatting (which I want to copy) as
well as the conditional formatting (which I do not want).

I created the conditions using VBA which work perfectly but it is
rather lengthy. I currently have 126 individual If/Then functions for
the formatting. I would like to know if there is a way to loop the
conditions so that it can significantly shorten the code. I am new to
the programming world and I was able to figure the following code out
from this news group.

Date = now()

If Range("F7").Value < Date Then Range("F7:G13").Interior.Pattern =
xlGray50 Else Range("F7:G13").Interior.Pattern = xlSolid
If Range("f7").Value = 1 And Range("F7:G13").Interior.ColorIndex = 15
Then Range("F7:G13").Interior.ColorIndex = 37
If Range("f7").Value = "" Then Range("F7:G13").Interior.ColorIndex = 15

These 3 lines of code are for a single block in the calendar and there
are a total of 42 blocks (7 across x 6 down) with the ranges of
F7:F13, H7:H13, J7:J13, L7:L13, N7:N13, P7:Q13, R7:R13 and then going
down the sheet to F14:F20, H14:H20, and on and on and on to a final
R35:S41.

Any help would be appreciated.

Try the following code (untested)

HTH
--
AP

'-------------------------------------------
Sub colors()

Dim iRow As Long
Dim iCol As Long

'Boucle sur les colonnes
For iCol = Range("F7").Column To Range("R7").Column Step 7
'Boucle sur les lignes
For iRow = Range("F7").Row To Range("R35").Row Step 2
doRange Cells(iRow, iCol)
Next iRow
Next iCol

End Sub

Sub doRange(rngTopLeft As Range)
With rngTopLeft.Resize(2, 7)
If rngTopLeft.Value < Date Then _
.Interior.Pattern = xlSolid
If rngTopLeft.Value = 1 And .Interior.ColorIndex = 15 Then _
.Interior.ColorIndex = 37
If rngTopLeft.Value = "" Then _
.Interior.ColorIndex = 15
End With
End Sub

Thank you for your response but this code did not work.

The cell shading line shaded all cells. If the top left target cell
value was not < the current date, all cells from F7:S48 were still
shaded except for ranges F7:L8, F21:L22, and F35:L36.

This code turned all cells except the above-mentioned ranges gray
without regard to the date and it turned range F7:L8 colorindex 37
while F21:L22 and F35:L36 had no color.

The original code did not go down to the bottom of the calenar so I
edited to following line from:

For iRow = Range("F7").Row To Range("R35").Row Step 2

to

For iRow = Range("F7").Row To Range("S48").Row Step 2
___________

This was the only fix I could find that helped. Granted I'm not too
familiar with programming but looking at the code, it seemed logical
and it looks like it should work but for some reason it didn't.

Try this:

'----------------------------------
Sub colors()

Dim iRow As Long
Dim iCol As Long

'Boucle sur les colonnes
For iCol = Range("F7").Column To Range("R7").Column Step 7
'Boucle sur les lignes
For iRow = Range("F7").Row To Range("R48").Row Step 2
doRange Cells(iRow, iCol)
Next iRow
Next iCol

End Sub

Sub doRange(rngTopLeft As Range)
With rngTopLeft.Resize(2, 7)
If rngTopLeft.Value < Date Then
.Interior.Pattern = xlGray50
Else
.Interior.Pattern = xlSolid
End If
If rngTopLeft.Value = 1 And .Interior.ColorIndex = 15 Then _
.Interior.ColorIndex = 37
If rngTopLeft.Value = "" Then _
.Interior.ColorIndex = 15
End With
End Sub
'------------------------------

Cheers,
--
AP


"rwnelson" a écrit dans le message de
oups.com...
Thank you for your response but this code did not work.

The cell shading line shaded all cells. If the top left target cell
value was not < the current date, all cells from F7:S48 were still
shaded except for ranges F7:L8, F21:L22, and F35:L36.

This code turned all cells except the above-mentioned ranges gray
without regard to the date and it turned range F7:L8 colorindex 37
while F21:L22 and F35:L36 had no color.

The original code did not go down to the bottom of the calenar so I
edited to following line from:

For iRow = Range("F7").Row To Range("R35").Row Step 2

to

For iRow = Range("F7").Row To Range("S48").Row Step 2
___________

This was the only fix I could find that helped. Granted I'm not too
familiar with programming but looking at the code, it seemed logical
and it looks like it should work but for some reason it didn't.

Still getting the same thing. Is there a way to display my sheet on
this site so that you may be able to better evaluate it?

Just as a test, I edited the doRange code just to see which cells were
identified as rngTopLeft. In column F, beginning at F7, every other
cell blue, instead of the top left of every block (i.e., F7, F9,
F11.....F47). The same goes for Column M. The code I entered is as
follows:

With rngTopLeft
.Interior.ColorIndex = 37
End With

End Sub

Please put your worksheet on http://cjoint.com/ (french site)

--
AP

"rwnelson" a écrit dans le message de
oups.com...
Just as a test, I edited the doRange code just to see which cells were
identified as rngTopLeft. In column F, beginning at F7, every other
cell blue, instead of the top left of every block (i.e., F7, F9,
F11.....F47). The same goes for Column M. The code I entered is as
follows:

With rngTopLeft
.Interior.ColorIndex = 37
End With

End Sub

Okay. I put it on the site (i think).

You have to paste (Ctrl-V) the generated file URL in your post, so that I
can open it

--
AP

"rwnelson" a écrit dans le message de
oups.com...
Okay. I put it on the site (i think).

Try this and again, thank you for all of your help

http://cjoint.com/?dmu71H4YXW

You original code does not perform what your comments say.

I re-wrote the code according to your comments.

HTH
--
AP

'----------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call colors

End Sub
Sub colors()

Dim iRow As Long
Dim iCol As Long

For iRow = Range("F7").Row To Range("R42").Row Step 7
For iCol = Range("F7").Column To Range("R42").Column Step 2
doRange Cells(iRow, iCol)
Next iCol
Next iRow


End Sub


Sub doRange(rngTopLeft As Range)

With rngTopLeft.Resize(7, 2)
'If range is less than current date then cell shading.
If rngTopLeft.Value < Date Then
.Interior.Pattern = xlGray50
Else
.Interior.Pattern = xlSolid
End If
'if range has a no value then grey
If rngTopLeft.Value = "" Then
.Interior.ColorIndex = 15
Else
'color blue/beige (37 for weekend, 40 for weekday)
Select Case Weekday(rngTopLeft.Value)
Case 1, 7 'Sunday or saturday
.Interior.ColorIndex = 37
Case Else
.Interior.ColorIndex = 40
End Select
End If
End With
End Sub
'-------------------------------------

"rwnelson" a écrit dans le message de
ups.com...
Try this and again, thank you for all of your help

http://cjoint.com/?dmu71H4YXW

Got it and worked perfectly. Thank you so much for all of your help.