Compile error: Procedure too large

J

JakeNaude

New Member
Joined
Apr 15, 2020
Messages
16
Office Version
  1. 365
Platform
  1. Windows
Hi,

Thanks for this fantastic forum... I often come here for excel/macro related answers but this is my first post!

Please could someone help me shorten my Excel 365 macro running on Windows 10

I ran into trouble when I started building a Worksheet_Change macro to change the colour of the buttons based on their cell values i.e. value = 0 makes button grey and value >0 gives button colour.

I get the compile error: Procedure too large in my Worksheet_Change(ByVal Target As Range) macro in Sheet29 (Shift Data) and need a hand shortening my code.

I have an 8000 row sheet which consists of many 22 row segments to collect Shift Data from engineers. To aid navigation I have about 300 shape "buttons" that filter to relevant 22 row segments.

Button names: SBDC1, SFC1, ZDC1 to ZDC20, FIB1 to FIB40, LPR1 to LPR180, POW1 to POW40, HPR1 to HPR40, JUM1 to JUM40

The buttons:
Capture - buttons.JPG


Sample Data:
Revised Station Progress Tracker II - 0.63.xlsm
FGHIJ
503Device (HPR001)In ProgressHPR NameHPR001
504HPR Location [SID]3/416
505HPR Room NameToilet
506HPR Network CabinetZDC6
507Shift Staff3staff
508Shift Budget (Planned)2shifts
509Shift Actual2shifts
510Estimated Remaining Shifts1shifts
511Estimated Remaining Shifts (Over Budget)1shifts
512Shifts Over Budget (Closing Actual)0shifts
513Shifts Under Budget (Closing Actual)0shifts
514Total Man Shifts (Actual)6man/shifts
515Task 1100%
516Task 2100%
517Task 3100%
518Task 4100%
519Task 5100%
520Task 6100%
521Task 7100%
522Task 8100%
523Task 9100%
524Task 10100%
Shift Data
Cell Formulas
RangeFormula
F503F503="Device ("&A504&")"
G503G503=IF(AND(I508>0,I510=0,I514>0,CZ503=1,I515=1,I516=1,I517=1,I518=1,I519=1,I520=1,I521=1,I522=1,I523=1,I524=1),"Installed - Tasks Completed", IF(AND(I508>0,I510>=0,I514>0,CZ503=1,OR(I515<1,I516<1,I517<1,I518<1,I519<1,I520<1,I521<1,I522<1,I523<1,I524<1)),"Installed - Tasks In Progress", IF(AND(I508>0,I510>0,I514>0,CZ503<1),"In Progress", IF(AND(I508>0,I510=0,I514=0),"Pending", IF(I508=0,"Not Planned", "Oops... Entered data not making sense!")))))
I509I509=COUNTA(L505:CY505)
I510I510=IF(SUM(L504:CY504)=0,0,LOOKUP(2,1/(ISNUMBER(L504:CY504)),L504:CY504))
I511I511=IF(I510=0,0,IF(I510>(I508-COUNT(L504:CY504)),(I509-I508+I510),0))
I512I512=IF(AND(I524="Yes",(I509-I508)>0),I509-I508,0)
I513I513=IF(AND(I524="Yes",(I509-I508)<0),I508-I509,0)
I514I514=COUNTA(L505:CY514)
I521:I524,I516:I519I516=CZ516
Cells with Conditional Formatting
CellConditionCell FormatStop If True
G503:G524Cell Value="Oops... Entered data not making sense!"textNO
G503:G524Cell Value="Installed - Tasks In Progress"textNO
G503:G524Cell Value="not planned"textNO
G503:G524Cell Value="pending"textNO
G503:G524Cell Value="in progress"textNO
G503:G524Cell Value="Installed - Tasks Completed"textNO


The macro:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
'******************************
' Fibre button colours - on/off
'******************************
    
    If Range("I2268").Value = 0 Then
        With ActiveSheet.Shapes("FIB1")
            .Fill.ForeColor.RGB = RGB(230, 230, 230)
            .Line.ForeColor.RGB = RGB(179, 179, 179)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
        End With
    Else
        With ActiveSheet.Shapes("FIB1")
            .Fill.ForeColor.RGB = RGB(0, 176, 80)
            .Line.ForeColor.RGB = RGB(50, 103, 50)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
        End With
    End If

    If Range("I2290").Value = 0 Then
        With ActiveSheet.Shapes("FIB2")
            .Fill.ForeColor.RGB = RGB(230, 230, 230)
            .Line.ForeColor.RGB = RGB(179, 179, 179)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
        End With
    Else
        With ActiveSheet.Shapes("FIB2")
            .Fill.ForeColor.RGB = RGB(0, 176, 80)
            .Line.ForeColor.RGB = RGB(50, 103, 50)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
        End With
    End If

    If Range("I2312").Value = 0 Then
        With ActiveSheet.Shapes("FIB3")
            .Fill.ForeColor.RGB = RGB(230, 230, 230)
            .Line.ForeColor.RGB = RGB(179, 179, 179)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
        End With
    Else
        With ActiveSheet.Shapes("FIB3")
            .Fill.ForeColor.RGB = RGB(0, 176, 80)
            .Line.ForeColor.RGB = RGB(50, 103, 50)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
        End With
    End If

    If Range("I2334").Value = 0 Then
        With ActiveSheet.Shapes("FIB4")
            .Fill.ForeColor.RGB = RGB(230, 230, 230)
            .Line.ForeColor.RGB = RGB(179, 179, 179)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
        End With
    Else
        With ActiveSheet.Shapes("FIB4")
            .Fill.ForeColor.RGB = RGB(0, 176, 80)
            .Line.ForeColor.RGB = RGB(50, 103, 50)
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
        End With
    End If

    'etc, etc, etc

End Sub

Factors considered in the macro:
Book1.xlsm
CDEFG
10Button NameValue = 0Value > 0Value Reference Cell/Range
11SBDC1 GreyLight blueI24
12SFC1GreyLight blueI486
13ZDC1 to ZDC20GreyLight blueI46, I68, I90… I464(every 22nd row downward)
14FIB1 to FIB40GreyGreenI2268, I2290, I2312… I3126(every 22nd row downward)
15LPR1 to LPR180GreyBlueI3148, I3170, I3192… I7086(every 22nd row downward)
16POW1 to POW40GreyOrangeI1388, I1410, I1432... I2246(every 22nd row downward)
17HPR1 to HPR40GreyBrownI508, I530, I552… I1366(every 22nd row downward)
18JUM1 to JUM40GreyPurpleI7108, I7130, I7152… I7966(every 22nd row downward)
Sheet1



Any help will be greatly appreciated.

Many thanks :)
 
Sort by date Sort by votes

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
With there being loads of buttons and presumably potential to create more id create a sheet, very hidden if required, of cell to shape relationships.

eg

A1Rectangle: Rounded Corners 1
230​
230​
230​
0​
176​
80​
A2Rectangle: Rounded Corners 2
230​
230​
230​
0​
176​
80​

where if cell A1 is changed then the action is on the first rectangle. You could even use that sheet to have different colours for different shapes if required as ive tried to demonstrate. You code then would be very reduced.
 
Upvote 0
JakeNaude

I assumed the 'buttons' were actually being clicked to change the cell values.

Since that's not the case the code Fluff posted is the way to go.

P.S. You might be able to determine the button name using the row number of the cell that's changed.
VBA Code: 
Dim lngButtonNum As Long

    lngButtonNum = (Target.Row - 2268)/22+1

    Set Shp = ActiveSheet.Shapes("FIB" & lngButtonNum)
 
Upvote 0
Norie said:
JakeNaude

I assumed the 'buttons' were actually being clicked to change the cell values.

Since that's not the case the code Fluff posted is the way to go.

P.S. You might be able to determine the button name using the row number of the cell that's changed.
VBA Code: 
Dim lngButtonNum As Long

    lngButtonNum = (Target.Row - 2268)/22+1

    Set Shp = ActiveSheet.Shapes("FIB" & lngButtonNum)
Click to expand...

Thanks Norie,

I'm busy building on Fluffs suggestion and will work your button name code in too... Cheers... (y)
 
Upvote 0
steve the fish said:
With there being loads of buttons and presumably potential to create more id create a sheet, very hidden if required, of cell to shape relationships.

eg

A1Rectangle: Rounded Corners 1
230​
230​
230​
0​
176​
80​
A2Rectangle: Rounded Corners 2
230​
230​
230​
0​
176​
80​

where if cell A1 is changed then the action is on the first rectangle. You could even use that sheet to have different colours for different shapes if required as ive tried to demonstrate. You code then would be very reduced.
Click to expand...
Hi Steve the Fish,

Thanks for your suggestion... I'll see if I can get my head round that... Cheers... (y)
 
Upvote 0
Norie said:
JakeNaude

I assumed the 'buttons' were actually being clicked to change the cell values.

Since that's not the case the code Fluff posted is the way to go.

P.S. You might be able to determine the button name using the row number of the cell that's changed.
VBA Code: 
Dim lngButtonNum As Long

    lngButtonNum = (Target.Row - 2268)/22+1

    Set Shp = ActiveSheet.Shapes("FIB" & lngButtonNum)
Click to expand...

Hi Norie,

Thanks for your suggestion... I'm building it in... So far so good... (y)

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
   
   Dim Shp As Shape
   Dim lngButtonNum As Long
   
   lngButtonNum = (Target.Row - 2268) / 22 + 1

   Set Shp = ActiveSheet.Shapes("FIB" & lngButtonNum)
    
   If Target.Value = 0 Then
       With Shp
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With
   Else
       With Shp
           .Fill.ForeColor.RGB = RGB(0, 176, 80)
           .Line.ForeColor.RGB = RGB(50, 103, 50)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
   End If

End Sub
 
Upvote 0
Fluff said:
One way to slim it down would be
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Shp As Shape
   Select Case Target.Address(0, 0)
      Case "I2268"
         Set Shp = ActiveSheet.Shapes("FIB1")
      Case "I2290"
         Set Shp = ActiveSheet.Shapes("FIB2")
      Case "I2312"
         Set Shp = ActiveSheet.Shapes("FIB3")
   End Select
   If Target.Value = 0 Then
       With Shp
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With
   Else
       With Shp
           .Fill.ForeColor.RGB = RGB(0, 176, 80)
           .Line.ForeColor.RGB = RGB(50, 103, 50)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
   End If

End Sub
Click to expand...
Hi Fluff,

Thanks, I tried that and it turns my FIB (green) buttons on and off - beautiful!

I'm having difficulty adapting the code to also work on my other buttons i.e. LPR (blue) buttons.

Please could you point me in the right direction?

Here's the adapted code that's obviously not working.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim ShpFIB As Shape
   Dim ShpLPR As Shape

   Select Case Target.Address(0, 0)

      Case "I2268"
         Set ShpFIB = ActiveSheet.Shapes("FIB1")

      Case "I2290"
         Set ShpFIB = ActiveSheet.Shapes("FIB2")

      Case "I2312"
         Set ShpFIB = ActiveSheet.Shapes("FIB3")

      Case "I3148"
         Set ShpLPR = ActiveSheet.Shapes("LPR1")
         
      Case "I3170"
         Set ShpLPR = ActiveSheet.Shapes("LPR2")
         
      Case "I3192"
         Set ShpLPR = ActiveSheet.Shapes("LPR3")
         
   End Select

   If Target.Value = 0 Then

       With ShpFIB
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With

   Else

       With ShpFIB
           .Fill.ForeColor.RGB = RGB(0, 176, 80)
           .Line.ForeColor.RGB = RGB(50, 103, 50)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
    
   End If

   If Target.Value = 0 Then

       With ShpLPR
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With

   Else

       With ShpLPR
           .Fill.ForeColor.RGB = RGB(0, 112, 192)
           .Line.ForeColor.RGB = RGB(0, 32, 96)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
       
   End If

End Sub
 
Upvote 0
Norie said:
JakeNaude

I assumed the 'buttons' were actually being clicked to change the cell values.

Since that's not the case the code Fluff posted is the way to go.

P.S. You might be able to determine the button name using the row number of the cell that's changed.
VBA Code: 
Dim lngButtonNum As Long

    lngButtonNum = (Target.Row - 2268)/22+1

    Set Shp = ActiveSheet.Shapes("FIB" & lngButtonNum)
Click to expand...

Hi Norie,

lngButtonNum idea was very clever.

I've adapted the following code that works on all 160 LPR shapes and numbers. However I can't figure out how to isolate/separate the code to also work for the other buttons i.e. JUM1 (I7108) to JUM40 (I7966) - (grey/purple).

Any tips would be appreciated... Cheers... :)

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim LPRShp As Shape
   Dim LPRButtonNum As Long

   LPRButtonNum = (Target.Row - 3148) / 22 + 1

   Set LPRShp = ActiveSheet.Shapes("LPR" & LPRButtonNum)

   If Target.Value = 0 Then
       With LPRShp
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With
   Else
       With LPRShp
           .Fill.ForeColor.RGB = RGB(0, 112, 192)
           .Line.ForeColor.RGB = RGB(0, 32, 96)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
   End If

End Sub
 
Upvote 0
Can you post the code you were using for the 'JUM' buttons?
 
Upvote 0
Norie said:
Can you post the code you were using for the 'JUM' buttons?
Click to expand...

Hi Norie,

FYI: I added a helper column to offer the button name which is offset (-4, -4) from the target cell.

Capture - jumper.JPG


Here's the code for the JUM buttons... :)

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim JUMshp As Shape
   Dim JUMbuttonNum As Long

   JUMbuttonNum = (Target.Row - 7108) / 22 + 1

   Set JUMshp = ActiveSheet.Shapes("JUM" & JUMbuttonNum)

   If Target.Value = 0 Then
       With JUMshp
           .Fill.ForeColor.RGB = RGB(230, 230, 230)
           .Line.ForeColor.RGB = RGB(179, 179, 179)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(179, 179, 179)
       End With
   Else
       With JUMshp
           .Fill.ForeColor.RGB = RGB(112, 48, 160)
           .Line.ForeColor.RGB = RGB(163, 101, 209)
           .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
       End With
   End If

End Sub
 
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
488
Georgiboy
Georgiboy
gravanoc
  • Question Question
Doughnut chart in Gauge chart not always set to correct axis group
Replies
0
Views
417
gravanoc
gravanoc
E
  • Question Question
Can anyone help me get my VBA code working? I have spent tons of time but can't quite fix it.
Replies
3
Views
3K
profray
P
K
  • Question Question
This is either an "existing connections" issue or a spreadsheet issue
Replies
1
Views
310
kaywai
K
A
  • Question Question
Help with existing code in Post - VBA to Create Org Chart
Replies
1
Views
2K
mrpotato562
M

Forum statistics

Threads
1,224,823
Messages
6,181,184
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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