Procedure Too Large - I know I should condense it, but I don't know how...

C

chandelirious

Board Regular
Joined
Sep 9, 2004
Messages
84
Hi there Excel Wizards,

I wonder if you can help me with a problem I'm having.

I'm creating a heat map in Excel, and after many months of struggle I've managed to source the code.

When I've put it together in VBA (of which my knowledge is zero), I get a Procedure Too Large message.

I've done some Googling on the issue, and discovered that this should not really happen, that it means that the code is messy. Too right it's messy!

Basically, I have 72 shapes that I need to colour, based on a value in a cell. The shape can be any of 7 colours depending on the value.

This is the code that I have at the moment:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
     
    If Not Intersect(Target, Range("B2")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 1 Then
                ActiveSheet.Shapes("001").Fill.BackColor.RGB = RGB(255, 255, 255)
ElseIf Target.Value >= 1 And Target.Value < 6 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(0, 255, 0)
ElseIf Target.Value >= 6 And Target.Value < 10 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf Target.Value >= 10 And Target.Value < 15 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(255, 64, 0)
ElseIf Target.Value >= 15 And Target.Value < 20 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target.Value >= 20 And Target.Value < 25 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(180, 4, 134)
ElseIf Target.Value >= 25 And Target.Value < 30 Then
                ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(132, 132, 132)
            Else
ActiveSheet.Shapes("001").Fill.ForeColor.RGB = RGB(0, 0, 0)
            End If
        End If
    End If
     
    If Not Intersect(Target, Range("B3")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 1 Then
                ActiveSheet.Shapes("002").Fill.BackColor.RGB = RGB(255, 255, 255)
ElseIf Target.Value >= 1 And Target.Value < 6 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(0, 255, 0)
ElseIf Target.Value >= 6 And Target.Value < 10 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf Target.Value >= 10 And Target.Value < 15 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(255, 64, 0)
ElseIf Target.Value >= 15 And Target.Value < 20 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target.Value >= 20 And Target.Value < 25 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(180, 4, 134)
ElseIf Target.Value >= 25 And Target.Value < 30 Then
                ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(132, 132, 132)
            Else
ActiveSheet.Shapes("002").Fill.ForeColor.RGB = RGB(0, 0, 0)
            End If
        End If
    End If

    If Not Intersect(Target, Range("B4")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 1 Then
                ActiveSheet.Shapes("003").Fill.BackColor.RGB = RGB(255, 255, 255)
ElseIf Target.Value >= 1 And Target.Value < 6 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(0, 255, 0)
ElseIf Target.Value >= 6 And Target.Value < 10 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf Target.Value >= 10 And Target.Value < 15 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(255, 64, 0)
ElseIf Target.Value >= 15 And Target.Value < 20 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target.Value >= 20 And Target.Value < 25 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(180, 4, 134)
ElseIf Target.Value >= 25 And Target.Value < 30 Then
                ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(132, 132, 132)
            Else
ActiveSheet.Shapes("003").Fill.ForeColor.RGB = RGB(0, 0, 0)
            End If
        End If
    End If

    If Not Intersect(Target, Range("B5")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 1 Then
                ActiveSheet.Shapes("004").Fill.BackColor.RGB = RGB(255, 255, 255)
ElseIf Target.Value >= 1 And Target.Value < 6 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(0, 255, 0)
ElseIf Target.Value >= 6 And Target.Value < 10 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf Target.Value >= 10 And Target.Value < 15 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(255, 64, 0)
ElseIf Target.Value >= 15 And Target.Value < 20 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target.Value >= 20 And Target.Value < 25 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(180, 4, 134)
ElseIf Target.Value >= 25 And Target.Value < 30 Then
                ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(132, 132, 132)
            Else
ActiveSheet.Shapes("004").Fill.ForeColor.RGB = RGB(0, 0, 0)
            End If
        End If
    End If

    If Not Intersect(Target, Range("B6")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 1 Then
                ActiveSheet.Shapes("005").Fill.BackColor.RGB = RGB(255, 255, 255)
ElseIf Target.Value >= 1 And Target.Value < 6 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(0, 255, 0)
ElseIf Target.Value >= 6 And Target.Value < 10 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(255, 128, 0)
ElseIf Target.Value >= 10 And Target.Value < 15 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(255, 64, 0)
ElseIf Target.Value >= 15 And Target.Value < 20 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target.Value >= 20 And Target.Value < 25 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(180, 4, 134)
ElseIf Target.Value >= 25 And Target.Value < 30 Then
                ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(132, 132, 132)
            Else
ActiveSheet.Shapes("005").Fill.ForeColor.RGB = RGB(0, 0, 0)
            End If
        End If
    End If
...

This repeats up until ...Shapes("072")...

I've managed to get the code working up until Shape 050, but then the code is too large.

So. Is there any way that I can streamline this code, or perhaps break it down?

I've tried breaking it into Sub Procedures, but either I didn't understand what I was doing or... no, I think I just didn't understand what I was doing.

It's half one in the morning here now, I'm going to bed, so apologies if you reply straight away and I don't, but I will check back here in the morning in case any of you geniuses have got some input for me!

Thanks again, I think you all do a fantastic job here.
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Hi
If I understand you right, you have equal changes for all activesheet shapes. Their differences are a number and a shape name only.
Code: 
Private Sub UpdateShape(ByVal shapeName As String, ByVal testValue As Double)
    With ActiveSheet.Shapes(shapeName)
        If testValue < 1 Then
            .Fill.BackColor.RGB = RGB(255, 255, 255)
        ElseIf testValue < 6 Then
            .Fill.ForeColor.RGB = RGB(0, 255, 0)
        ElseIf testValue < 10 Then
            .Fill.ForeColor.RGB = RGB(255, 128, 0)
        ElseIf testValue < 15 Then
            .Fill.ForeColor.RGB = RGB(255, 64, 0)
        ElseIf testValue < 20 Then
            .Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf testValue < 25 Then
            .Fill.ForeColor.RGB = RGB(180, 4, 134)
        ElseIf testValue < 30 Then
            .Fill.ForeColor.RGB = RGB(132, 132, 132)
        Else
            .Fill.ForeColor.RGB = RGB(0, 0, 0)
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        If IsNumeric(Target.Value) Then
            If Not Intersect(Target, Range("B2")) Is Nothing Then UpdateShape "001", Target.Value
            If Not Intersect(Target, Range("B3")) Is Nothing Then UpdateShape "002", Target.Value
            'etc
        End If
    End If
End Sub
Regards,
 
Upvote 0
anvg, I simplified you code a bit more. I put the .Fill up in the With. Also, the Change event should now handle all of the shapes without adding an If for each row in the sheet.

Code: 
Private Sub UpdateShape(ByVal shapeName As String, ByVal testValue As Double)
    With ActiveSheet.Shapes(shapeName).Fill
        If testValue < 1 Then
            .BackColor.RGB = RGB(255, 255, 255)
        ElseIf testValue < 6 Then
            .ForeColor.RGB = RGB(0, 255, 0)
        ElseIf testValue < 10 Then
            .ForeColor.RGB = RGB(255, 128, 0)
        ElseIf testValue < 15 Then
            .ForeColor.RGB = RGB(255, 64, 0)
        ElseIf testValue < 20 Then
            .ForeColor.RGB = RGB(255, 0, 0)
        ElseIf testValue < 25 Then
            .ForeColor.RGB = RGB(180, 4, 134)
        ElseIf testValue < 30 Then
            .ForeColor.RGB = RGB(132, 132, 132)
        Else
            .ForeColor.RGB = RGB(0, 0, 0)
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 And Target.Column = 2 And (Target.Row >= 2 And Target.Row <= 73) Then
        If IsNumeric(Target.Value) Then
            UpdateShape Right("00" & Target.Row - 1, 3), Target.Value
        End If
    End If
End Sub
 
Upvote 0
Solution
djreiswig said:
anvg, I simplified you code a bit more. I put the .Fill up in the With. Also, the Change event should now handle all of the shapes without adding an If for each row in the sheet.

Code: 
Private Sub UpdateShape(ByVal shapeName As String, ByVal testValue As Double)
    With ActiveSheet.Shapes(shapeName).Fill
        If testValue < 1 Then
            .BackColor.RGB = RGB(255, 255, 255)
        ElseIf testValue < 6 Then
            .ForeColor.RGB = RGB(0, 255, 0)
        ElseIf testValue < 10 Then
            .ForeColor.RGB = RGB(255, 128, 0)
        ElseIf testValue < 15 Then
            .ForeColor.RGB = RGB(255, 64, 0)
        ElseIf testValue < 20 Then
            .ForeColor.RGB = RGB(255, 0, 0)
        ElseIf testValue < 25 Then
            .ForeColor.RGB = RGB(180, 4, 134)
        ElseIf testValue < 30 Then
            .ForeColor.RGB = RGB(132, 132, 132)
        Else
            .ForeColor.RGB = RGB(0, 0, 0)
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 And Target.Column = 2 And (Target.Row >= 2 And Target.Row <= 73) Then
        If IsNumeric(Target.Value) Then
            UpdateShape Right("00" & Target.Row - 1, 3), Target.Value
        End If
    End If
End Sub
Click to expand...

Thank you SO MUCH!

I can't believe how complicated mine was, when the actual needed code was so short.

The code works like a treat, thanks again so much for your input.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
How to Make this Macro work Fast?
Replies
2
Views
479
Georgiboy
Georgiboy
E
  • Question Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
521
offthelip
O
H
  • Solved
Query not pulling right info when running in VBA
2
Replies
13
Views
385
Holley
H
J
  • Solved
How to aggregate data based on multiple criteria?
Replies
8
Views
1K
Jurez
J
L
  • Solved
auto repeating the dates in specific cells in column by writing in two input box
Replies
3
Views
252
mumps
mumps

Forum statistics

Threads
1,223,246
Messages
6,170,988
Members
452,373
Latest member
TimReeks

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