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

答案在这里：relational algebra calculator

基本上，VBA的每个过程限制为64k，因此只需将您的子对象拆分为多个子对象：

所以代替：

 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

希望这应该更好，并且您应该能够对其进行调整，使其更适合您的需求。

Answer 2

我在您的代码中看到很多重复。重复可以通过两种方法来管理：创建子例程或创建循环。

首先：确定模式：

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

要点：

没有重复
列表项
更短，更容易理解和维护
可以管理Target中已更改的多个单元格
这是对其进行编码的一种方法-但要识别模式和重复元素是第一步。
我还使用了类型安全的方法，将潜在的变量元素转换为期望的类型（无隐式转换）

上面的代码可以更整洁吗-是的，但确实说明了该过程。

Answer 3

enter image description here @ 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

还附有截图，谢谢。

手续大

3 个答案: