Need help condensing VBA

I

IBAUCLAPlaya

Board Regular
Joined
Dec 17, 2007
Messages
99
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 -->
 
Last edited by a moderator:

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
Hi,

Maybe try the following (not tested so you may need to tweak it a little to work for you, but hopefully you get the general idea):

Code: 
Sub example()

Dim i As Long, j As Long, k As Long
Dim IC As Long

For i = 1 To 13 ' 13 columns
    For j = 1 To 65 ' 65 rows
        IC = 1 'if none of the conditions below are met 1 is the default colour
        Select Case Sheets("Master").Cells(466 + j, 11 + i).Value
            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 Sheets("Master").Range(70 + j, 11 + i).Value > 0 Then
                    IC = 22
                End If
        End Select
        For k = 0 To 28
            Sheets("Master").Cells(Array(5, 71, 137, 203, 269, 335, 401, 467, 533, 599, 669, 741, 812, 883, 954, 1025, 1096, 1167, 1233, 1299, 1365, 1436, 1507, 1573, 1644, 1715, 1786, 1857, 1928)(k), 11 + j).Interior.ColorIndex = IC
        Next k
        Sheets("QUICKView").Range(Cells(12 + ((i - 1) * 18), 2 + j), Cells(29 + ((i - 1) * 18), 2 + j)).Interior.ColorIndex = IC
    Next j
Next i

End Sub
 
Upvote 0
Thanks! I see what type of logic you are trying to use, but I tried pasting it into the worksheet object but nothing happens. I'm thinking there may be a small piece of coding wrong that is preventing it from working at all, but unfortunately I'm not what.

Can you please look into and test/fix?
 
Upvote 0
Are you sure those ranges are correct? There's very little uniformity to them. Assuming you have a little more uniformity and I have misunderstood, perhaps you could use this change event...

Code: 
Option Explicit

Private Const sRangeToCheck = "L467:X531"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim IC_1_1 As Long, iViewRow As Long, sCol As String, iLoop As Long
    If Intersect(Target, Me.Range(sRangeToCheck)) Is Nothing Then Exit Sub
    Select Case Target.Value
        Case "FC":      IC_1_1 = 3
        Case "BC":      IC_1_1 = 45
        Case "ADFEAT":  IC_1_1 = 4
        Case "AD":      IC_1_1 = 6
        Case "LL":      IC_1_1 = 40
        Case "ROP":     IC_1_1 = 41
        Case "AMD":     IC_1_1 = 26
        Case "MB":      IC_1_1 = 31
        Case "AAM":     IC_1_1 = 8
        Case Is > 0:    IC_1_1 = 22
    End Select
    iViewRow = Target.Row - 449
    sCol = Split(Target.Address(), "$")(0)
    For iLoop = 5 To 69
        Me.Cells(iLoop, sCol).Interior.ColorIndex = IC_1_1
    Next iLoop
    Sheets("QUICKView").Range(sCol & iViewRow & ":" & sCol & iViewRow + 18).Interior.ColorIndex = IC_1_1
End Sub

Not sure if I deciphered your code well enough, I only used a couple of examples. Can you explain the logic?

Or the same code without a loop, but IMHO uglier...

Code: 
Option Explicit

Private Const sRangeToCheck = "L467:X531"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim IC_1_1 As Long, iRow As Long, sCol As String, iLoop As Long
    If Intersect(Target, Me.Range(sRangeToCheck)) Is Nothing Then Exit Sub
    Select Case Target.Value
        Case "FC":      IC_1_1 = 3
        Case "BC":      IC_1_1 = 45
        Case "ADFEAT":  IC_1_1 = 4
        Case "AD":      IC_1_1 = 6
        Case "LL":      IC_1_1 = 40
        Case "ROP":     IC_1_1 = 41
        Case "AMD":     IC_1_1 = 26
        Case "MB":      IC_1_1 = 31
        Case "AAM":     IC_1_1 = 8
        Case Is > 0:    IC_1_1 = 22
    End Select
    sCol = Split(Target.Address(), "$")(0)
    iRow = Target.Row - 467
    Me.Range(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 + 1164 & "," & _
             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).Interior.ColorIndex = IC_1_1
    iRow = Target.Row - 449
    Sheets("QUICKView").Range(sCol & iRow & ":" & sCol & iRow + 18).Interior.ColorIndex = IC_1_1
End Sub
 
Upvote 0
Ok I tried all three of these are none are formatting any of the cells when I change the key values.

Basically, when I enter one of the conditions in cell L467 or enter a value greater than zero in L71, I want the formatting of the following cells affected:
Master sheet - L5,L71,L137,L203,L269,L335,L401,L467,L533,L599,L669,L741,L812,L883,L954,L1025,L1096,L1167,L1233,L1299,L1365,L1436,L1507,L1573,L1644,L1715,L1786,L1857,L1928
Quickview sheet - C12:C29

I want this same rule to carry down 65 rows and across 13 columns from L467 & L71.

So for a random example, if I adjusted M467 or M71 (one column over to the right), I would want all of the cells affected in the Master sheet in the M column and then all of the cells affected in the Quickview sheet in the D column (one column over to the right from the original code)

Another random example, if I adjust O478 or O82 (11 rows down and 3 columns over from original L467/L71), then I would want all of the cells affected in the Master sheet to be 11 rows down and 3 columns over from the original list of cells posted above.
In the Quickview sheet, I would want the reference to be 11 rows * 18 = 198 rows down and 3 columns over from the original C12:C29 yielding F210:F227.

Does this make sense?
I can send my spreadsheet to someone if they PM me if that will help.

Thanks again for the quick help.
 
Upvote 0
A slight alteration works for me...

Code: 
Option Explicit

Private Const sRangeToCheck = "L467:X531"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim IC_1_1 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
    Select Case Target.Value
        Case "FC":      IC_1_1 = 3
        Case "BC":      IC_1_1 = 45
        Case "ADFEAT":  IC_1_1 = 4
        Case "AD":      IC_1_1 = 6
        Case "LL":      IC_1_1 = 40
        Case "ROP":     IC_1_1 = 41
        Case "AMD":     IC_1_1 = 26
        Case "MB":      IC_1_1 = 31
        Case "AAM":     IC_1_1 = 8
        Case Is > 0:    IC_1_1 = 22
    End Select
    sCol = Split(Target.Address(), "$")(1)
    iRow = Target.Row - 467
    Me.Range(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).Interior.ColorIndex = IC_1_1
    iRow = Target.Row - 455
    Sheets("QUICKView").Range(sCol & iRow & ":" & sCol & iRow + 17).Interior.ColorIndex = IC_1_1
End Sub

EDIT: What this code doesn't do is un-highlight the cells. If you want to clear the cells of their interior colors, you would need to add this line of code in the appropriate place...

Code: 
    Me.Range("L:L").Interior.ColorIndex = 0
    Sheets("QUICKView").Range("L:L").Interior.ColorIndex = 0

HTH
 
Last edited:
Upvote 0
Thanks...this is working but a few issues still:
The case of value > 0 needs to check cell L71 and not L467. The rest of the cases are correct for L467.
The formatting in the "QuickView" sheet is incorrect. Example: if I make L467 = "AD", cells L12:L29 highlight on the QuickView sheet when it should be C12:C29.
If I make Q495 = "AD" cells H498:H515 should highlight but instead Q40:Q57 highlight.
 
Upvote 0
Hi,

I'm sure Zack Barresse's solution would probably be the better way to go, but maybe you can try mine as part of a worksheet change event i.e.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Long, j As Long, k As Long
Dim IC As Long

For i = 1 To 13 ' 13 columns
    For j = 1 To 65 ' 65 rows
        IC = 1 'if none of the conditions below are met 1 is the default colour
        Select Case Sheets("Master").Cells(466 + j, 11 + i).Value
            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 Sheets("Master").Range(70 + j, 11 + i).Value > 0 Then
                    IC = 22
                End If
        End Select
        For k = 0 To 28
            Sheets("Master").Cells(Array(5, 71, 137, 203, 269, 335, 401, 467, 533, 599, 669, 741, 812, 883, 954, 1025, 1096, 1167, 1233, 1299, 1365, 1436, 1507, 1573, 1644, 1715, 1786, 1857, 1928)(k), 11 + j).Interior.ColorIndex = IC
        Next k
        Sheets("QUICKView").Range(Cells(12 + ((i - 1) * 18), 2 + j), Cells(29 + ((i - 1) * 18), 2 + j)).Interior.ColorIndex = IC
    Next j
Next i

End Sub
 
Upvote 0
I got an "Application defined or Object defined error" on the following piece of your code:
Code: 
If Sheets("Master").Range(70 + j, 11 + i).Value > 0 Then
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Help with VBA code for a userform
Replies
1
Views
252
dmt32
D
A
  • Question
Workbook taking forever to load ...
2 3
Replies
21
Views
828
adambc
A
J
  • Solved
Remove cell contents based on date - VBA
Replies
3
Views
493
kevin9999
K
B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
243
birdman15
B
N
  • Solved
Help for Data Analyses
2 3
Replies
22
Views
631
Newbie73
N

Forum statistics

Threads
1,214,990
Messages
6,122,626
Members
449,093
Latest member
catterz66

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top