Need help condensing VBA

[IBAUCLAPlaya]

I wrote the following macro to basically allow for conditional formatting in Excel 2003 with 10 conditions. Basically the formula is doing the same thing over and over again 845 times (65 rows x 13 colums).
I have this saved in the worksheet so that it automatically updates every time I change something but the code is WAYYY too long and errors out.
Is there any way to condense this so it still works?

<!- Extremely long content removed -->

 

[Zack Barresse]

I'm going to post what I have, although I know it needs a couple of tweaks. One I know it needs for sure is that the uncolor of the Quickview sheet needs to be altered slightly, as that isn't working properly.

But this uses a standard module with the following code...

Option Explicit

Public Const sRangeToCheck = "L71:X135,L467:X531,L1299:X1363"

Sub ColorRange(ByVal Target As Range, bReverse As Boolean)

    Dim WS                          As Worksheet
    Dim iColor                      As Long
    Dim iColor2                     As Long
    Dim iRow                        As Long
    Dim iRow2                       As Long
    Dim iRowStart                   As Long
    Dim iLoop                       As Long
    Dim sRangeToColor               As String
    Dim sCol                        As String
    Dim sTemp()                     As String
    Dim bColorFont                  As Boolean

    Static sLastRange               As String
    Static sLastQV                  As String

    Dim rIR As Range, rMARKER       As Range
    Dim rIRCREDIT As Range, rIntersect As Range

    Set WS = Target.Parent
    Set rIR = WS.Range("IR_Data")
    Set rMARKER = WS.Range("Marker_Data")
    Set rIRCREDIT = WS.Range("IRCredit_Data")

    If Not Intersect(Target, rIR) Is Nothing Then
        iRowStart = rIR(1, 1).Row
    ElseIf Not Intersect(Target, rMARKER) Is Nothing Then
        iRowStart = rMARKER(1, 1).Row
    ElseIf Not Intersect(Target, rIRCREDIT) Is Nothing Then
        iRowStart = rIRCREDIT(1, 1).Row
    End If

    iRow = Target.Row - iRowStart    ' 467

    iColor = 0
    iColor2 = 0
    bColorFont = False
    If Not bReverse Then
        Select Case Target.Value
        Case "FC": iColor = 3
        Case "BC": iColor = 45
        Case "ADFEAT": iColor = 4
        Case "AD": iColor = 6
        Case "LL": iColor = 40
        Case "ROP": iColor = 41
        Case "AMD": iColor = 26
        Case "MB": iColor = 31
        Case "AAM": iColor = 8
        End Select
        If WS.Cells(rIR(1, 1).Row + iRow, Target.Column).Value > 0 Then
            iColor = 22
            iColor2 = 12
        End If
'        If WS.Cells(iRow + 71, sCol).Value > 0 Then iColor = 22
    End If
    If WS.Cells(rIRCREDIT(1, 1).Row + iRow, Target.Column).Value > 0 Then iColor2 = 12
    If iColor2 > 0 Then
        bColorFont = True
        iColor2 = iColor
    End If
'    If WS.Cells(iRow + 71, sCol).Value > 0 Then iColor = 22

    sCol = Split(Target.Address(), "$")(1)

    If sLastRange <> vbNullString Then
        WS.Range(sLastRange).Interior.ColorIndex = 0
        If sLastQV <> vbNullString Then
            iRow2 = ((Target.Row - iRowStart) * 18) + 12
            Sheets("QUICKView").Range("C" & iRow2 & ":C" & iRow2 + 16).Interior.ColorIndex = 0
            Sheets("QUICKView").Range("C" & iRow2 + 17).Interior.ColorIndex = 0
            If bColorFont = True Then
                Sheets("QUICKView").Range("C" & iRow2 + 17).Font.Bold = False
                Sheets("QUICKView").Range("C" & iRow2 + 17).Font.ColorIndex = 1
            End If
        End If
    End If
    sRangeToColor = CStr(sCol & iRow + 5 & "," & sCol & iRow + 71 & "," & sCol & iRow + 137 & "," & _
                         sCol & iRow + 203 & "," & sCol & iRow + 269 & "," & sCol & iRow + 335 & "," & _
                         sCol & iRow + 401 & "," & sCol & iRow + 467 & "," & sCol & iRow + 533 & "," & _
                         sCol & iRow + 599 & "," & sCol & iRow + 669 & "," & sCol & iRow + 741 & "," & _
                         sCol & iRow + 812 & "," & sCol & iRow + 883 & "," & sCol & iRow + 954 & "," & _
                         sCol & iRow + 1025 & "," & sCol & iRow + 1096 & "," & sCol & iRow + 1167 & "," & _
                         sCol & iRow + 1233 & "," & sCol & iRow + 1299 & "," & sCol & iRow + 1365 & "," & _
                         sCol & iRow + 1436 & "," & sCol & iRow + 1507 & "," & sCol & iRow + 1573 & "," & _
                         sCol & iRow + 1644 & "," & sCol & iRow + 1715 & "," & sCol & iRow + 1786 & "," & _
                         sCol & iRow + 1857 & "," & sCol & iRow + 1928)
    WS.Range(sRangeToColor).Interior.ColorIndex = iColor
    sLastRange = sRangeToColor

    '    iRow = Target.Row - 455
    iRow = ((Target.Row - iRowStart) * 18) + 12
    Sheets("QUICKView").Range("C" & iRow & ":C" & iRow + 16).Interior.ColorIndex = iColor
    Sheets("QUICKView").Range("C" & iRow + 17).Interior.ColorIndex = iColor2
    If bColorFont = True Then
        Sheets("QUICKView").Range("C" & iRow + 17).Font.Bold = True
        Sheets("QUICKView").Range("C" & iRow + 17).Font.ColorIndex = 3
    End If
    sLastQV = "C" & iRow & ":C" & iRow + 17

End Sub

In your worksheet module of the 'Master' worksheet, use this code...

Option Explicit

Private iLastCol As Long
Private iLastRow As Long

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim iColor As Long, iRow As Long, sCol As String, iLoop As Long, sTemp() As String
    If Intersect(Target, Me.Range(sRangeToCheck)) Is Nothing Then Exit Sub
    If iLastRow = 0 Xor iLastCol = 0 Then
        Call ColorRange(Me.Cells(iLastRow, iLastCol), True)
    End If
    Call ColorRange(Target, False)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    iLastCol = Target.Column
    iLastRow = Target.Row
End Sub

Test it out and see if it works. I'm not entirely familiar with how this is supposed to work for you, so it seems to be working in testing for me, but it was only limited testing. Let us know.

 

[IBAUCLAPlaya]

Getting an error every time I try to do something on the following line of code:
Set rIR = WS.Range("IR_Data")
"Method range of object worksheet failed"

??

 

[Zack Barresse]

Oh dang, forgot to post that. I made 3 named ranges. IR_Data, Master_Data and IRCredit_Data, all pointing to their respective data range you want to check, from col L to X.

 

[IBAUCLAPlaya]

Gotcha. When testing the example I posted, it's not doing what I need it to (comments in parenthesis):
(I keyed the three below values in order)
L467 = "AD"
L71 = 20
L1299 = 10
The formatting for this should be color 6 for groups A & B and color 12,bold,red font for group C. (Group A, B & C color are all 22)
Now if I was to clear cell L1299, Group C color should change to color 6 and groups A & B should stay color 6 (no changes to above...all color stays 22)
Now if I cleared cell L467, Groups A,B,C should all change to color 22 (this is correct but it was already color 22)
Now if I added the value 10 back to L1299, Groups A,B shoudl stay 22 but Group C should now be color 12 again. (All groups are still color 22)
Now if I clear L71 and L1299, Groups A,B,C formats should go back to no fill

Also, starting from scratch if I make just L467 = "AD", Group C should be color 6 but doesn't update at all.
When I then key 10 into L1299, Group C should change to Green BG, red color, bold, and groups A & B should stay color 6. This doesn't happen...All color goes away

 

[circledchicken]

Hi,

Another attempt from me - put this code in the MASTER worksheet object. It could probably be made a bit better but just getting it to work would be great at this stage i think!

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim IR As Range, MARKER As Range, IR_CREDIT As Range
Dim GroupA As Range, GroupB As Range, GroupC As Range
Dim offRows As Long
Dim iC As Long, iC2 As Long
Dim iBold As Boolean, iFont As Long

Set IR = Sheets("MASTER").Range("L71:X135")
Set MARKER = Sheets("MASTER").Range("L467:X531")
Set IR_CREDIT = Sheets("MASTER").Range("L1299:X1363")

If Not Intersect(Target, Sheets("MASTER").Range("L71:X135,L467:X531,L1299:X1363")) Is Nothing Then

    Set GroupA = Sheets("MASTER").Range("L5,L71,L137,L203,L269,L334,L401,L467,L533,L599,L669,L740,L812,L883,L954,L1025,L1096,L1167,L1233,L1299,L1365,L1436,L1507, L1573,L1644,L1715,L1786,L1857,L1928")
    Set GroupB = Sheets("Quickview").Range("C12:C28")
    Set GroupC = Sheets("Quickview").Range("C29")
    
    Select Case Target.Row
        Case Is < 467
            offRows = Target.Row - 71
        Case Is < 1299
            offRows = Target.Row - 467
        Case Else
            offRows = Target.Row - 1299
    End Select

    iC = 0
    Select Case MARKER(offRows + 1, Target.Column - 11)
            Case "FC": iC = 3
            Case "BC": iC = 45
            Case "ADFEAT": iC = 4
            Case "AD": iC = 6
            Case "LL": iC = 40
            Case "ROP": iC = 41
            Case "AMD": iC = 26
            Case "MB": iC = 31
            Case "AAM": iC = 8
            Case Else:
            If IR(offRows + 1, Target.Column - 11) > 0 Then
                iC = 22
            End If
    End Select
    Select Case IR_CREDIT(offRows + 1, Target.Column - 11)
            Case Is > 0
                iC2 = 12
                iBold = True
                iFont = 9 ' red
            Case Else: iC2 = iC
                iBold = False
                iFont = 1 ' black
    End Select
    
    GroupA.Offset(offRows, Target.Column - 12).Interior.ColorIndex = iC
    GroupB.Offset(offRows * 18, Target.Column - 12).Interior.ColorIndex = iC
    With GroupC.Offset(offRows * 18, Target.Column - 12)
        .Interior.ColorIndex = iC2
        .Font.Bold = iBold
        .Font.ColorIndex = iFont
    End With
    
End If

End Sub

Note that it only works on the most recently changed values column and associated groups, rather than looping through everything every time there is a change - I assume that's what you want.

There are three subsets I'm looking to check. For simplicity let's refer to them as IR, MARKER and IR CREDIT:
IR - Master Sheet(L467:X531)
MARKER - Master Sheet(L71:X135)
IR CREDIT - Master Sheet(L1299:X1363)

Also I assume in your earlier post that the MARKER range and IR range should be the other way around (as per the worksheet and your examples).

 

[IBAUCLAPlaya]

Circledchicken,
Awesome! This code appears to be working for the most part. You are correct in that I had IR and MARKER ranges flopped.

One of the cells in group A was incorrect...it should be L335 instead of L334.
I changed that.

The other thing that happened at first was when I entered a value into the IR CREDIT range and then deleted it, the formatting didn't go away. But now it seems to be working fine...weird.

The only other ask I have (small detail at this point and not sure if it's possible) is if I copy a cell and paste across a range of cells at one time, it will only update formatting on the first cell pasted to. Is there a way to account for this or no?

 

[Zack Barresse]

You will need to loop. When you have multiple cells selected the entire range is passed as the 'Target' variable to the change event. To do each cell individually, you can loop like this...

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCell As Range
    For Each rCell In Target.Cells
        'YOUR CODE HERE, REPLACE "Target" WITH "rCell" INSIDE THIS LOOP
    Next rCell
End Sub

 

[circledchicken]

You will need to loop. When you have multiple cells selected the entire range is passed as the 'Target' variable to the change event. To do each cell individually, you can loop like this...

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCell As Range
    For Each rCell In Target.Cells
        'YOUR CODE HERE, REPLACE "Target" WITH "rCell" INSIDE THIS LOOP
    Next rCell
End Sub

I didn't think of that - thats nice to learn - thanks!!

 

[Zack Barresse]

Btw, nice job circledchicken! Very nice code.

 

[circledchicken]

Btw, nice job circledchicken! Very nice code.

Thanks for the compliment - I learn so much from all of you here!