Excel 2003 question. on conditional formatting using VBA

[Closed]
Report
Posts
3
Registration date
Tuesday May 26, 2015
Status
Member
Last seen
June 6, 2015
-
Posts
3
Registration date
Tuesday May 26, 2015
Status
Member
Last seen
June 6, 2015
-
Hello,

i have been trying to figure out how to make my code stop bugging out on me. any and all help will be greatly appreciated.
Option Compare Text 'A=a, B=b, ... Z=z
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Integer

Dim Cell As Range
Dim CellB As Range
Dim lnCurrent As Long, lnRange As Long
Dim q As String
Dim qq As String
Dim dq As String
Dim y As String
Dim dy As String
Dim m As String
Dim dm As String

'Find out what Quarter we are in
q = Format(Date, "q")
'Find out what Year we are in
y = Format(Date, "yy")
'Find out what Month we are in
m = Format(Date, "mm")


If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub

For Each Cell In Range("A:A")
Select Case Cell.Value
Case vbNullString

Case "Q" ' quarterly
r = Target.Row

'Find out what quarter and year the inputed date is in
dq = Format(Range("B" & r), "q")
dy = Format(Range("B" & r), "yy")

If (q = dq) And (y = dy) Then
Range("B" & r).Interior.ColorIndex = 4 'Green
ElseIf q = 1 Then
If (y - 1) = dy And dq = 4 Then
Range("B" & r).Interior.ColorIndex = 8 'Teal
Else
Range("B" & r).Interior.ColorIndex = 3 'red
End If
ElseIf q > 1 Then
If (q - 1) >= 1 And (q - 1) = dq And y = dy Then
Range("B" & r).Interior.ColorIndex = 8 'Teal
Else
Range("B" & r).Interior.ColorIndex = 3 'red
End If
Else
Range("B" & r).Interior.ColorIndex = 3 'Red
End If

Case "M" 'monthly
' for later use
Case "Y" ' yearly
' for later use
Case "S" ' Semiannually
' for later use
Case Else

Range("B" & r).Interior.ColorIndex = xlNone
Cell.Interior.ColorIndex = xlNone

End Select
Next

For Each CellB In Range("B:B")
Select Case CellB.Value
Case Null
CellB.Interior.ColorIndex = xlNone
Case vbNullString
CellB.Interior.ColorIndex = xlNone
End Select
Next

'If Target.Count > 1 Then Exit Sub

End Sub


OK so here is what im trying to do and some what getting the response i expect. Column A has single letters (Q,M,S,Y). i have it made so i will color code the cells in Column B. based off the Case from Column A. every thing works great if i fill in Column B first but if i put a Q in column A i get a Type mismatch on this line of code any i just dont know why.
If (q - 1) >= 1 And (q - 1) = dq And y = dy Then
I think im going about this the wrong way but cant figure out any other way. im not to worried about M,S,Y should be much easier after i figure out Q.

Any and all help will be greatly appreciated.

Thank you in advance,

1 reply

Posts
3
Registration date
Tuesday May 26, 2015
Status
Member
Last seen
June 6, 2015

Ok so i got this code to work, but I'm having issues with making it work in multiple columns. Column A:name1 B:Date1 C:name2 D:Date2
Columns A and C will have either (M,Q) and will eventually have more for different functions like bimonthly,Semiannual,Yearly.

Option Compare Text 'A=a, B=b, ... Z=z
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Integer

Dim Cell As Range
Dim q, qq, dq
Dim y, dy, m
Dim dm, dd
Dim ldtm, td, fdlm
'Find out what Quarter we are in
q = Format(Date, "q")
'Find out what Year we are in
y = Format(Date, "yy")
'Find out what Month we are in
m = Format(Date, "mm")

'If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
    r = Target.Row
    For Each Cell In Range("A2:A45")
        Select Case Cell.Value
            Case vbNullString
                If Range("A" & r) = Empty Then
                    Range("B" & r).Interior.ColorIndex = 1
                    Exit Sub
                Else
                    Cell.Interior.ColorIndex = 1
                End If
            Case "Q" ' quarterly
                If Range("B" & r).Value = Empty Then
                    Range("B" & r).Interior.ColorIndex = xlNone
                    Exit Sub
                Else
                'Find out what quarter and year the inputed date is in
                    dq = Format(Range("B" & r), "q")
                    dy = Format(Range("B" & r), "yy")
                    If (q = dq) And (y = dy) Then
                        Range("B" & r).Interior.ColorIndex = 4 'Green
                        Exit Sub
                    ElseIf q = 1 Then
                        If (y - 1) = dy And dq = 4 Then
                            Range("B" & r).Interior.ColorIndex = 8 'Teal
                            Exit Sub
                        Else
                            Range("B" & r).Interior.ColorIndex = 3 'red
                            Exit Sub
                        End If
                    ElseIf q > 1 Then
                        If ((q - 1) >= 1) And (q - 1) = dq And (y = dy) Then
                            Range("B" & r).Interior.ColorIndex = 8 'Teal
                            Exit Sub
                        Else
                            Range("B" & r).Interior.ColorIndex = 3 'red
                            Exit Sub
                        End If
                    Else
                        Range("B" & r).Interior.ColorIndex = 3 'Red
                        Exit Sub
                    End If
                End If
            Case "M" 'monthly
                If Range("B" & r).Value = Empty Then
                    Range("B" & r).Interior.ColorIndex = xlNone
                    Exit Sub
                Else
                    dm = Format(Range("B" & r), "mm")
                    dy = Format(Range("B" & r), "yy")
                    td = Format(Range("B" & r), "mm/dd/yy") 'formate todays date
                    ldtm = Format(DateSerial(Year(Date), Month(Date) + 1, 0), "mm/dd/yy") 'get last day of next month
                    fdlm = Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm/dd/yy") 'get first day of last month
                    If (y = dy) And (m = dm) Then
                            Range("B" & r).Interior.ColorIndex = 4 'Green
                            Exit Sub
                        ElseIf (td <= ldtm) And (td >= fdlm) Then
                            Range("B" & r).Interior.ColorIndex = 8 'Teal
                            Exit Sub
                        ElseIf (dm = 12) And (dy = (y - 1)) And (m = 1) Then
                            Range("B" & r).Interior.ColorIndex = 8 'Teal
                            Exit Sub
                    Else
                        Range("B" & r).Interior.ColorIndex = 3 'Red
                        Exit Sub
                    End If
                End If
            Case "Y" ' yearly
              '  for later use
            Case "S" ' Semiannually
              '  for later use
            Case Else
                Cell.Interior.ColorIndex = 1
        End Select
    Next
End Sub


this code works just fine for columns A and B but when i try to copy the code to make it for the next set of columns it doesnt do anything except in column B. if i remove the Exit Sub from the Cases it will only show green and no other color.

The purpose for this code is to make it possible to review binders/Programs and have multiple personnel review them and update when they did so that we know when the last one was done and if its coming up for review or missed.