Question

我大约有。一张纸上的100个矩形。我想更改一个我知道其TopLeftCell坐标的特定矩形的颜色。

我希望能够直接选择此矩形来更改其颜色，但是我找不到任何VBA代码来执行此操作。目前，我能找到的唯一代码是，选择工作表上的所有形状，然后在工作表上查找每个形状与TopLeftCell的交集，然后选择该矩形以更改其颜色。

可能要检查100个形状，这似乎是一种效率很低的方法，我认为必须有更好的方法。

Dim sh as shape

For Each sh In ActiveSheet.Shapes
    If Not Intersect(Cells(RowNumber, ColumnNumber), sh.TopLeftCell) Is Nothing Then
        sh.Select False
        Selection.Interior.ColorIndex = 3
        Selection.ShapeRange.Fill.Visible = msoTrue
        Selection.ShapeRange.Fill.Solid
    End If
Next sh

我想知道是否有类似的代码

selection.shape.topleftcell(cells(RowNumber,ColumnNumber))

或类似的在VBA中是可能的。我尝试了这种方法以及其他类似的代码，但是都给出了错误。

Answer 1

像这样运行loop一次，将Rectangles的名称更改为其TopLeftCell的地址

 Dim sh As Shape

 For Each sh In ActiveSheet.Shapes

    sh.Name = sh.TopLeftCell.Address

 Next sh

现在，您可以使用以下任何其他代码直接访问形状：

ActiveSheet.Shapes(ActiveCell.Address).Select

这是实现它的一种方法。尽管不存在您要寻找的方法。

您可以更改ActiveCell.Address的任何范围对象，也可以仅更改文本本身。它将采用$D$4

之类的值

经过测试，可以顺利运行。

Answer 2

如果您要做的只是Select设置要更改颜色的形状，则只需：

Sub changeColor()
    Selection.Interior.ColorIndex = 3
End Sub

如果您想以更有条理的方式访问Shape的其他属性，我建议使用TopLeftCell作为键在Dictionary中收集Shape名称。然后您可以执行以下操作：

Option Explicit
'Set Reference to Microsoft Scripting Runtime
Public dShapes As Dictionary
Private Sub refShapes()
    Dim WS As Worksheet
    Dim SH As Shape

Set WS = ActiveSheet
Set dShapes = New Dictionary
    dShapes.CompareMode = TextCompare
For Each SH In WS.Shapes
    dShapes.Add Key:=SH.topLeftCell.Address, Item:=SH.Name
Next SH

End Sub

Sub changeColor()
    Dim SH As Shape
    Dim topLeftCell As String

topLeftCell = Selection.topLeftCell.Address

refShapes

If dShapes.Exists(topLeftCell) Then
    Set SH = ActiveSheet.Shapes(dShapes(topLeftCell))
    SH.Fill.ForeColor.RGB = RGB(255, 0, 255)
    SH.Fill.Visible = msoTrue
    SH.Fill.Solid
Else
    MsgBox ("No shape at that location")
End If
End Sub

但是，如果您有多个具有相同TopLeftCell的形状，则此技术将失败，但可以根据需要进行调整以解决这种情况。

如果您知道形状的左上单元格行和列，可以直接选择形状吗

2 个答案: