通过任何目标中的公式更改触发多目标VBA脚本操作

我是VBA的新手，并设法通过改变表格来控制对象的颜色。

此时我有7个对象（A〜G），我创build了6种不同颜色的variables（1〜6）。 这些数字应该不断扩大。 特别是可以定义的对象的数量，我希望能达到几百个。 目的是创build大型仪表盘/可视化，并能够从电子表格中控制它们。

问题是D12〜D18中的公式不会触发颜色变化。 只有手动input的单元格触发它。 我一直在寻找很久，但是我找不到解决办法。 主要问题是目标的数量。 有没有人有任何想法？

示例文件： Test-Objects.xlsm

Private Sub Worksheet_change(ByVal Target As Range) If Application.Intersect(Target, Range("D12:D300")) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub Select Case Target.Address(False, False) Case "D12" shapename = "objectA" Case "D13" shapename = "objectB" Case "D14" shapename = "objectC" Case "D15" shapename = "objectD" Case "D16" shapename = "objectE" Case "D17" shapename = "objectF" Case "D18" shapename = "objectG" End Select With testobjects.Shapes(shapename).Fill.ForeColor Select Case Target Case Is = "1" .RGB = RGB(180, 0, 0) Case Is = "2" .RGB = RGB(220, 0, 0) Case Is = "3" .RGB = RGB(255, 95, 83) Case Is = "4" .RGB = RGB(255, 165, 129) Case Is = "5" .RGB = RGB(0, 97, 240) Case Is = "6" .RGB = RGB(0, 176, 240) End Select End With End Sub 

以上代码来自表单以及来自模块的以下代码：

 Sub whatever() ShapeColor = Abs(Range("F2") = 0) * 10 + Abs(Range("F2") = 40) * 3 With testobjects.Shapes("CustShp").Fill .ForeColor.SchemeColor = ShapeColor .Solid End With End Sub 

祝你2016年的最后几天都好！

Answer 1

编辑2切换到WorkBook_SheetChange()方法

根据您的进一步说明，您必须处理来自不同纸张和数百种形状的“明智”细胞

所以你可能想要：

• 切换to Workbook_SheetChange()事件处理程序以放置在ThisWorkbook代码窗格中

  这将允许您截取在任何工作表中更改的任何单元格

• 有办法识别一个“明智”的细胞

  要么定义它们的一个集合（一个Dictionary可以适合这个），要么以一种独特的方式标记它们，例如是具有黄色背景色的唯一单元格

  因为你的例子有“明智的”细胞黄色我会去与后者

所以这是一个可能的代码：

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim cell As Range If Target.count > 1 Then Exit Sub If Target.Interior.ColorIndex <> 6 Then Exit Sub '<--| exit sub if changed cell is not a "sensible" one With testobjects '<--| reference your "shapes" sheet For Each cell In .Range("D12:D300").SpecialCells(xlCellTypeFormulas, xlNumbers) '<--| loop through its "no. (select):" cells containing a number resulting out of a formula .Shapes("object" & cell.Offset(, -1)).Fill.ForeColor.RGB = GetRGB(cell.Value) '<--| update current "no (select)" corresponding shape color Next End With End Sub 

正如你所看到的，按照你的例子，这个形状是以“objectX”命名的，其中“X”是从对应的“no（select）”值的左边一列的单元格中取出的

这样，你不需要任何数组来存储形状名称，并简单地将它们从testobjects表单中testobjects

而对于GetRGB()函数，你已经看到了下面的select：

• select案例方法

   Function GetRGB(val As Integer) As Long Select Case val Case 1 GetRGB = RGB(180, 0, 0) Case 2 GetRGB = RGB(220, 0, 0) Case 3 GetRGB = RGB(255, 95, 83) Case 4 GetRGB = RGB(255, 165, 129) Case 5 GetRGB = RGB(0, 97, 240) Case 6 GetRGB = RGB(0, 176, 240) End Select End Function 

• Choose()函数的方法

   Function GetRGB(val As Integer) As Long GetRGB = Choose(val, RGB(180, 0, 0), RGB(220, 0, 0), RGB(255, 95, 83), RGB(255, 165, 129), RGB(0, 97, 240), RGB(0, 176, 240)) End Function 

  你必须确定val必须在1到函数列出的选项数之间，否则返回一个空值和形状（shapesArr（iShp））。Fill.ForeColor.RGB = GetRGB（.Cells（ iShp + 1）.Value）`会出错

  如果这种例外是可能的，你可能需要添加一些If或者坚持Select Case方法或者尝试下面的方法

• Dictionary方法

   Function GetRGB(val As Integer) As Long With CreateObject("scripting.dictionary") '<-- use a late binding "on the fly" dictionary instantiation .Add 1, RGB(180, 0, 0) '<--| associate "key" '1' to "Value" 'RGB(180, 0, 0)' .Add 2, RGB(220, 0, 0) '<--| same as above .Add 3, RGB(255, 95, 83) .Add 4, RGB(255, 165, 129) .Add 5, RGB(0, 97, 240) .Add 6, RGB(0, 176, 240) GetRGB = .item(val) '<--| return the value associated with 'val' "key" End With End Function 

  返回一个零（即黑色 ） val应该不匹配任何硬编码的keys

Answer 2

Worksheet_Change事件的代码不需要将testobjects作为前缀，因为ActiveWorksheet默认值是代码的位置，以及放置形状的位置。

由于您已经将Range限制为“D12：D300”，因此您稍后可以使用Select Case Target.Row因为您已经将Range降至了D列。

 Option Explicit Public testobjects As Worksheet Private Sub Worksheet_change(ByVal Target As Range) Dim shapename As String ' setting the testobjects to "Shhet2" >> modify to your sheet with the "objects" Set testobjects = Worksheets("Sheet2") If Application.Intersect(Target, Range("D12:D300")) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub Select Case Target.Row Case 12 shapename = "objectA" Case 13 shapename = "objectB" Case 14 shapename = "objectC" Case 15 shapename = "objectD" Case 16 shapename = "objectE" Case 17 shapename = "objectF" Case 18 shapename = "objectG" End Select With testobjects.Shapes(shapename).Fill.ForeColor Select Case CLng(Target.Value) Case 1 .RGB = RGB(180, 0, 0) Case 2 .RGB = RGB(220, 0, 0) Case 3 .RGB = RGB(255, 95, 83) Case 4 .RGB = RGB(255, 165, 129) Case 5 .RGB = RGB(0, 97, 240) Case 6 .RGB = RGB(0, 176, 240) End Select End With End Sub