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

Question

我是 VBA 的新手，并设法开始使用一个脚本，可以通过更改表格来控制对象的颜色。

此时我有 7 个对象 (A ~ G)，并为 6 种不同的颜色 (1 ~ 6) 创建了变量。这些数字应该继续可扩展。特别是可定义的对象的数量，我预计会增加到数百个。目的是创建大型仪表板/可视化效果，并能够从电子表格控制它们。

问题是 D12 ~ D18 中的公式不会触发颜色更改。只有单元格上的手动输入才会触发它。我已经寻找了很长时间，但找不到解决方案。主要问题是目标的数量。有人有什么想法吗？

示例文件：测试对象.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()方法

根据您的进一步说明，您必须处理来自不同工作表和数百种形状的"明智"单元格

因此，您可能需要：

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

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

• 有办法识别"敏感"细胞

  您可以定义它们的集合(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"取自相应"否(选择)"值左边一列的单元格

这样，您就不需要任何数组来存储形状名称，只需将它们从工作表Shapes集合中取出testobjects

"即时"至于GetRGB()功能，您已经看到了以下替代方案：

• 选择案例方法

  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 到函数中列出的选项数，否则它将返回 Null 值和 Shapes(shapesArr(iShp))。Fill.ForeColor.RGB = GetRGB(.细胞(iShp + 1)。值)' 将出错

  如果可能存在此类异常，您可能需要添加一些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