Процедура для большого

Question

я новичок в VBA, только что начал в маленьком проекте, где у меня есть 427 фигур, каждая фигура будет меняться в соответствии с соответствующим числом, введенным в ячейку, все работало до тех пор, пока не обошло форму 100+, где написано «процедура большая", может кто-нибудь помочь мне обойтись, я пытаюсь проверить использование sub, но не могу заставить его работать.

Большое спасибо

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

Answer 1

Я вижу много повторений в вашем коде.Повторением можно управлять двумя способами: создать подпрограмму или создать цикл.

Первый: определить шаблон:

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

• Проверка ячейки "W" +«некоторое число»
• Выбор формы «некоторое число», отформатированной так, чтобы она состояла из 3 цифр
• Изменение цвета формы на основе значения в ячейке

Первый удар в процедуре:

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

Во-вторых: определить повторение

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

Ключевые моменты:

• Нет повторений
• Списокitem
• Короче и проще для понимания и обслуживания
• Может управлять несколькими ячейками в цели, которая изменилась
• Это один из способов ее кодирования, но с определением шаблона иповторяющиеся элементы - это первый шаг.
• Я также использовал безопасные от типов методы, преобразуя потенциальные переменные элементы в ожидаемый тип (без неявного преобразования)

Может ли приведенный выше код бытьнемного аккуратнее - да, но это иллюстрирует процесс.

Answer 2

введите описание изображения здесь @ AJD, см. Код

Private Sub ChangeColour(rowNumber As Long, ws As Worksheet)
    With ws.Range("W" & CStr(rowNumber))
        Select Case .Value
            Case >0 And <=56
                ws.Shapes(Format(rowNumber, "000")).ShapeRange.Fill.ForeColor.RGB = ThisWorkbook.Colors(CInt(.Value))
            Case Else
                ws.Shapes(Format(rowNumber, "000")).ShapeRange.Fill.ForeColor.RGB = 0
        End Select
    End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellIterator As Range
    For Each cellIterator In Me.Range("W1:W427")
        If Not Intersect(Target, cellIterator) Is Nothing Then
            ChangeColour(cellIterator.Row,Me)
        End If
    Next cellIterator
End Sub

также прикреплен скриншот спасибо заранее.

Answer 3

Ответ здесь: https://stackoverflow.com/a/3751303/2790342

В основном, VBA имеет ограничение в 64 КБ на процедуру, поэтому просто разделите ваш саб на несколько сабов:

Итак, вместо:

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

Используйте это:

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

Наслаждайтесь.

Редактировать: В ответ на ваш комментарий и после прочтения другого ответа я замечаю, что вы в основном зацикливаете ту же функцию.Таким образом, мы можем упростить его, написав его только один раз:

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

Надеюсь, это должно работать лучше, и вы сможете настроить его лучше для своих нужд.