0

im new to VBA, just started on the small project where I have 427 shapes, each shape will change in the corresponding number entered on a cell, everything was working till a hit around shape 100+ where is says "procedure to large", can somebody help me a way around, im trying to check to use sub but cannot really get it working.

Thanks so much

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("W1")) Is Nothing Then
    Me.Shapes("001").Select
    With Range("W1")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
    If Not Intersect(Target, Range("W2")) Is Nothing Then
    Me.Shapes("002").Select
    With Range("W2")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W3")) Is Nothing Then
    Me.Shapes("003").Select
    With Range("W3")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W4")) Is Nothing Then
    Me.Shapes("004").Select
    With Range("W4")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W5")) Is Nothing Then
    Me.Shapes("005").Select
    With Range("W5")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W6")) Is Nothing Then
    Me.Shapes("006").Select
    With Range("W6")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W7")) Is Nothing Then
    Me.Shapes("007").Select
    With Range("W7")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W8")) Is Nothing Then
    Me.Shapes("008").Select
    With Range("W8")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W9")) Is Nothing Then
    Me.Shapes("009").Select
    With Range("W9")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W10")) Is Nothing Then
    Me.Shapes("010").Select
    With Range("W10")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W11")) Is Nothing Then
    Me.Shapes("011").Select
    With Range("W11")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W12")) Is Nothing Then
    Me.Shapes("012").Select
    With Range("W12")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W13")) Is Nothing Then
    Me.Shapes("013").Select
    With Range("W13")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W14")) Is Nothing Then
    Me.Shapes("014").Select
    With Range("W14")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W15")) Is Nothing Then
    Me.Shapes("015").Select
    With Range("W15")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W16")) Is Nothing Then
    Me.Shapes("016").Select
    With Range("W16")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W17")) Is Nothing Then
    Me.Shapes("017").Select
    With Range("W17")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W18")) Is Nothing Then
    Me.Shapes("018").Select
    With Range("W18")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W19")) Is Nothing Then
    Me.Shapes("019").Select
    With Range("W19")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W20")) Is Nothing Then
    Me.Shapes("020").Select
    With Range("W20")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W21")) Is Nothing Then
    Me.Shapes("021").Select
    With Range("W21")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W22")) Is Nothing Then
    Me.Shapes("022").Select
    With Range("W22")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W23")) Is Nothing Then
    Me.Shapes("023").Select
    With Range("W23")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W24")) Is Nothing Then
    Me.Shapes("024").Select
    With Range("W24")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W25")) Is Nothing Then
    Me.Shapes("025").Select
    With Range("W25")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W26")) Is Nothing Then
    Me.Shapes("026").Select
    With Range("W14")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W27")) Is Nothing Then
    Me.Shapes("027").Select
    With Range("W27")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W28")) Is Nothing Then
    Me.Shapes("028").Select
    With Range("W28")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W29")) Is Nothing Then
    Me.Shapes("029").Select
    With Range("W29")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W30")) Is Nothing Then
    Me.Shapes("030").Select
    With Range("W30")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W31")) Is Nothing Then
    Me.Shapes("031").Select
    With Range("W31")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W32")) Is Nothing Then
    Me.Shapes("032").Select
    With Range("W32")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W33")) Is Nothing Then
    Me.Shapes("033").Select
    With Range("W33")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W34")) Is Nothing Then
    Me.Shapes("034").Select
    With Range("W34")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W35")) Is Nothing Then
    Me.Shapes("035").Select
    With Range("W35")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W36")) Is Nothing Then
    Me.Shapes("036").Select
    With Range("W36")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W37")) Is Nothing Then
    Me.Shapes("037").Select
    With Range("W37")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W38")) Is Nothing Then
    Me.Shapes("038").Select
    With Range("W38")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W39")) Is Nothing Then
    Me.Shapes("039").Select
    With Range("W39")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W40")) Is Nothing Then
    Me.Shapes("040").Select
    With Range("W40")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W41")) Is Nothing Then
    Me.Shapes("041").Select
    With Range("W41")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W42")) Is Nothing Then
    Me.Shapes("042").Select
    With Range("W42")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W43")) Is Nothing Then
    Me.Shapes("043").Select
    With Range("W43")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W44")) Is Nothing Then
    Me.Shapes("044").Select
    With Range("W44")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W45")) Is Nothing Then
    Me.Shapes("045").Select
    With Range("W45")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
    End With
End If
If Not Intersect(Target, Range("W46")) Is Nothing Then
    Me.Shapes("046").Select
    With Range("W46")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W47")) Is Nothing Then
    Me.Shapes("047").Select
    With Range("W47")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W48")) Is Nothing Then
    Me.Shapes("048").Select
    With Range("W48")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W49")) Is Nothing Then
    Me.Shapes("049").Select
    With Range("W49")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
If Not Intersect(Target, Range("W50")) Is Nothing Then
    Me.Shapes("050").Select
    With Range("W50")
        If .Value > 0 And .Value <= 56 Then
            Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
        Else
            Selection.ShapeRange.Fill.ForeColor.RGB = 0
        End If
        .Select
End With
End If
erico
  • 11
  • There are a number of "Procedure too large" questions on this site. You should really follow the advice of @AJD and refactor your code properly - you'll learn a lot.https://stackoverflow.com/questions/32706131/vba-excel-procedure-too-large https://stackoverflow.com/questions/41026198/vba-procedure-too-large https://stackoverflow.com/questions/3751263/procedure-too-large – Nick.Mc Feb 05 '19 at 07:22

2 Answers2

1

The answer is here: https://stackoverflow.com/a/3751303/2790342

Basically, VBA has limit of 64k per procedure, so just split your sub into multiple subs:

So instead of:

 Sub GiantProcedure()
      ... ' lots and lots of code
 End Sub

Use this:

Sub GiantProcedure()
      ... ' a little bit of common code
      Proc1()
      Proc2()
      Proc3()

 End Sub

 Sub Proc1()
      ... ' quite a bit of code
 End Sub

 Sub Proc2()
      ... ' quite a bit of code
 End Sub

 Sub Proc3()
      ... ' quite a bit of code
 End Sub

Enjoy.

Edit: In response to your comment, and after reading another answer, I notice that you are basically looping the same function. So, we can simplify it to write it only once:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i as Integer, shape_name as String, range_name as String

    For i = 1 to 50 'This can keep going upto 427 for all your shapes
        range_name = "W" & i 

        'For the shape name, we need to add 0 in front of the number so it's 3 digits which is slightly tricky.
        if i < 10 Then
            shape_name = "00" & i
        If i >= 10 And i < 100 Then
            shape_name = "0" & i  
        If i >= 100 Then
            shape_name = i
        End If

        If Not Intersect(Target, Range(range_name)) Is Nothing Then
            Me.Shapes(shape_name).Select
            With Range(range_name)
                If .Value > 0 And .Value <= 56 Then
                    Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
                Else
                    Selection.ShapeRange.Fill.ForeColor.RGB = 0
                End If
                .Select
            End With
        End If
    Next i
End Sub

Hopefully, this should work better, and you should be able to tweak it better suit your needs.

PuravTheGreat
  • 136
  • 12
  • Hi @PuravTheGreat I found this thread but I cannot get it running into the code would be appreciated if you could show the code for the above only for the Sub GiantProcedure() upto Sub Proc1 () based on my posted code.thanks a lot in advance. – erico Feb 05 '19 at 06:44
  • Hi @PuravTheGreat, thanks that's another way to look at the code but im having error on `Next i` , saying Compile error: Next without for, whats seems to be the problem? – erico Feb 06 '19 at 05:44
  • Hi @erico, I'm unsure why that would throw an error because we have a for loop going, so after we try say i = 1, we then want to try i = 2, then i = 3. Can you make sure the`Next i` line is at the same indentation level as the `For i = 1 to 50` line and get back to me. Thanks. – PuravTheGreat Feb 06 '19 at 05:47
  • Hi @PuravTheGreat, ived adjusted the `Next i` same indention but still compile error – erico Feb 06 '19 at 06:02
  • Hi @erico, I think I know what the issue might be, my if statements. Can you change the If i >= 10 statement to ElseIf i >= 10 and the same with If i >= 100 statement. The End If is only closing one of the Ifs I believe so the next i isn't connected to the For loop. – PuravTheGreat Feb 06 '19 at 06:18
  • Hi @PuravTheGreat, wow amazing !!!! it works now all 427 change to whatever colour.Thanks a lot super great.!!!! – erico Feb 06 '19 at 06:46
  • @erico Ayy! That's great to hear! – PuravTheGreat Feb 06 '19 at 09:30
  • @erico, I did realise if you wanted to just select all shapes in a sheet there's an easier way: `Dim sh as Shape; and then For Each sh in ActiveSheet.Shapes; sh.DoSomething; Next sh` (I have used ; to indicate new line.) Basically a loop for each shape, that way you don't have to worry about how many shapes you have or anything. – PuravTheGreat Feb 06 '19 at 09:44
  • yeah great solution, my first attempt was very long and tedious, your loop code was very short and to the point, thanks alot!!!! – erico Feb 06 '19 at 11:38
0

I see a lot of repetition in your code. Repetition can be managed by two methods: creating a sub-routine, or creating a loop.

First: Identify the pattern:

If Not Intersect(Target, Range("W2")) Is Nothing Then
Me.Shapes("002").Select
With Range("W2")
    If .Value > 0 And .Value <= 56 Then
        Selection.ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(.Value)
    Else
        Selection.ShapeRange.Fill.ForeColor.RGB = 0
    End If
    .Select
End With
  • Checking a cell "W" + "some number"
  • Selecting a shape "some number" formatted to be 3 digits
  • Changing the colour of the shape based on the value in the cell

First stab at a routine:

Private Sub ChangeColour(rowNumber as Long, ws as Worksheet)
    With ws.Range("W" & CStr(rowNumber)) ' Identify the cell to be checked
        Select Case .Value
            Case >0 And <=56
                ' Change the colour based on a condition
                ws.Shapes(Format(rowNumber,"000")).ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(CInt(.Value))
                ' Having selected the shape which is named the same as the row number, but formatted to 3 digits.
            Case Else
                ws.Shapes(Format(rowNumber,"000")).ShapeRange.Fill.ForeColor.RGB = 0
        End Select
    End With
End Sub

Secondly: identify the repetition

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellIterator as Range
    For Each cellIterator in Me.Range("W1:W50") ' naybe this is W1:W300 in your version?
        If Not Intersect(Target, cellIterator) Is Nothing Then
            ChangeColour(cellIterator.Row,Me)
        End If
    Next cellIterator
End Sub

Key points:

  • No repetition
  • List item
  • Shorter and easier to understand and maintain
  • Can manage multiple cells in the Target that has changed
  • This is one way of coding it - but identifying the pattern and the repetitive elements is the first step.
  • I have also used type-safe methods, converting potential variable elements to the expected type (no implicit conversion)

Could the code above be a little neater - yes, but it does illustrate the process.

AJD
  • 2,400
  • 2
  • 12
  • 22
  • @AJDgreat solution very less code compared to mine, but im having error from Private Sub Worksheet_Change(ByVal Target As Range) hes reading it as compile error, syntax error what seems to be the problem? – erico Feb 05 '19 at 09:21
  • @erico Do you have `Option Explicit` at the top of the module? This may help in highlighting which line has the syntax error. – AJD Feb 05 '19 at 18:25