Excel 是否可以使用add.connector将单元格与形状连接起来

我只是在玩

Add.Connector

（在这里看到了另一篇关于这一点的帖子，我只是好奇这有什么可能）。

我对这个主题做了一些搜索，发现你可以用这种方法连接两个形状。然而，我并没有发现任何能表明我能将形状连接到细胞上的东西。这可能吗？我想是的，但由于我对这个问题缺乏知识，我无法理解。

这里有一个例子：我有一张纸，看起来像这样

这就是我想要实现的目标：

到目前为止，我掌握的代码如下：

Sub TestThis()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape
    Dim iC As Long

    For iC = 5 To 7
        Set oS = oWS.Shapes.AddShape(1, 800, iC * 120 - 599, 100, 100)
        oS.Name = "SomeNewShape1"
        oS.TextFrame.Characters.Text = "Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
    Next

End Sub

---

如前所述，上面的代码来自我在这里看到的另一篇文章。代码运行良好，如果我想连接到另一个形状，我可以实现。我不知道如何连接到手机。如果您有任何帮助，我们将不胜感激。

电池没有连接器。如果您确实想要一个连接器，而不仅仅是一个自由浮动端，那么您可以在单元上放置一个不可见的形状，如下所示：

Private Function AddInvisibleRectangle(ByVal Target As Range) As Shape

    Dim shpTMP As Shape
    Set shpTMP = Target.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                            Target.Left, Target.Top, Target.Width, Target.Height)

    shpTMP.Fill.Visible = msoFalse
    shpTMP.Line.Visible = msoFalse
    shpTMP.Placement = xlMoveAndSize
    Set AddInvisibleRectangle = shpTMP

End Function

{EDIT}刚刚运行了一个快速测试，并注意到了一些有趣的事情-如果您通过调整形状穿过的行/列的大小来拉伸形状，并且这会更改连接器所在侧的长度，那么连接器在您尝试修改它之前不会正确显示…

如果您有点“作弊”，您可以这样做：

• 创建具有单元位置的形状
• 连接到该形状
• 删除形状

-

这就是你得到的：

---

为了让将来其他人看到这一点，下面是我所做的

所以我要做的是在a列中有一个值列表。然后我在我的类中运行这个函数，它创建的形状和我在a列中的值一样多，并且设置形状名称和文本，就像它在相应的单元格中一样。虚拟形状放置在每个单元格的右上角，以便可以访问这些单元格。如果更改相应单元格的值，它还会更新形状的名称和文本。这就是它看起来的样子：

这是我的班级：

Private Function AddInvisibleRectangle(ByVal Target As Range) As Shape

    Dim shpTMP As Shape
    Set shpTMP = Target.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                            Target.Left + Target.Width - 2, Target.Top, Target.Width - (Target.Width - 2), (Target.Height / 2) / 2)

    shpTMP.Fill.Visible = msoFalse
    shpTMP.Line.Visible = msoFalse
    shpTMP.Placement = xlMoveAndSize
    shpTMP.Name = Replace(Target.Address, "$", "")
    Set AddInvisibleRectangle = shpTMP

End Function

Sub ShapesAndConnectors()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")     ' Change to your source sheet
    Dim oS As Shape
    Dim iC&, iFirstR&, iLastR&, iLast&
    Dim oDS As New Scripting.Dictionary
    Dim oI As Variant
    Dim oDummyS As Shape
    Dim oCon As Shape

    iFirstR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).End(xlUp).Row
    iLastR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).Row
    iLast = 5

    For iC = iFirstR To iLastR

        ' Add a shape
        Set oS = oWS.Shapes.AddShape(1, 400, iLast, 100, 40)
        oS.Name = oWS.Range("A" & iC).Value
        oS.TextFrame.Characters.Text = oWS.Range("A" & iC).Value    '"Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
        iLast = iLast + oS.Height + 10

        ' Add a dummy shape for the cell
        Set oDummyS = AddInvisibleRectangle(oWS.Range("A" & iC))

        ' Add it to dictionary
        oDS.Add oS.Name, oDummyS

    Next

    ' Create connectors
    For iC = 0 To oDS.count - 1
        Set oCon = oWS.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
        oCon.ConnectorFormat.BeginConnect oDS.Items(iC), 1
        oCon.ConnectorFormat.EndConnect oWS.Shapes(oDS.Keys(iC)), 2
        oCon.Line.ForeColor.RGB = RGB(255, 0, 0)
        oCon.Line.EndArrowheadStyle = msoArrowheadTriangle
    Next

End Sub

Sub ClearShapes()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    For Each oS In oWS.Shapes
        oS.Delete
    Next
End Sub

Function UpdateShapeText(ByVal sShapeName As String, ByVal sNewText As String) As Boolean
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    UpdateShapeText = True

    For Each oS In oWS.Shapes
        If LCase(Trim(oS.Name)) = LCase(Trim(sNewText)) Then
            UpdateShapeText = False
            Exit Function
        End If
    Next

    For Each oS In oWS.Shapes
        If oS.Name = sShapeName Then
            oS.Name = sNewText
            oS.TextFrame.Characters.Text = sNewText
            Exit For
        End If
    Next

End Function

---

我在课堂上硬编码了工作表，但这只是我在玩连接器

你查了

Shapes.AddConnector

方法的文档了吗？@ashleedawg：我不会说我查了这个主题的文档，但我确实查了微软在那里的网站（）还有其他一些站点，但不幸的是，据我所知，它们都是指两个形状之间的连接件。我想知道如何获得单元格的坐标。。每天学习新东西：）。但问题是，如果我删除第二个（虚拟）形状，连接器还会工作吗？i、 e.如果我移动形状，线条会自动调整吗？@Zac-在代码中，虚拟形状被删除，屏幕截图在后面。如果移动接头，则会重新调整。每天学习新东西是一种美妙的感觉，祝贺你完美的我要为此痛骂一顿。我要试试看。快速提问，一旦形状被添加，用户是否仍然能够与单元格交互？我想我很快就会发现我已经解决了这个问题，把你的答案和Vityta的答案结合起来。因此，如果单元格值发生变化，形状中的文本将改变为单元格的值。我选择Vityata的答案纯粹是因为我喜欢删除虚拟形状的想法，但感谢您的输入，您可能无法单击它-您可以通过将形状移动到单元格右侧，并将宽度设置为0来解决此问题，但这需要在创建形状之前知道要连接到单元的哪一侧

Private Function AddInvisibleRectangle(ByVal Target As Range) As Shape

    Dim shpTMP As Shape
    Set shpTMP = Target.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                            Target.Left + Target.Width - 2, Target.Top, Target.Width - (Target.Width - 2), (Target.Height / 2) / 2)

    shpTMP.Fill.Visible = msoFalse
    shpTMP.Line.Visible = msoFalse
    shpTMP.Placement = xlMoveAndSize
    shpTMP.Name = Replace(Target.Address, "$", "")
    Set AddInvisibleRectangle = shpTMP

End Function

Sub ShapesAndConnectors()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")     ' Change to your source sheet
    Dim oS As Shape
    Dim iC&, iFirstR&, iLastR&, iLast&
    Dim oDS As New Scripting.Dictionary
    Dim oI As Variant
    Dim oDummyS As Shape
    Dim oCon As Shape

    iFirstR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).End(xlUp).Row
    iLastR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).Row
    iLast = 5

    For iC = iFirstR To iLastR

        ' Add a shape
        Set oS = oWS.Shapes.AddShape(1, 400, iLast, 100, 40)
        oS.Name = oWS.Range("A" & iC).Value
        oS.TextFrame.Characters.Text = oWS.Range("A" & iC).Value    '"Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
        iLast = iLast + oS.Height + 10

        ' Add a dummy shape for the cell
        Set oDummyS = AddInvisibleRectangle(oWS.Range("A" & iC))

        ' Add it to dictionary
        oDS.Add oS.Name, oDummyS

    Next

    ' Create connectors
    For iC = 0 To oDS.count - 1
        Set oCon = oWS.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
        oCon.ConnectorFormat.BeginConnect oDS.Items(iC), 1
        oCon.ConnectorFormat.EndConnect oWS.Shapes(oDS.Keys(iC)), 2
        oCon.Line.ForeColor.RGB = RGB(255, 0, 0)
        oCon.Line.EndArrowheadStyle = msoArrowheadTriangle
    Next

End Sub

Sub ClearShapes()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    For Each oS In oWS.Shapes
        oS.Delete
    Next
End Sub

Function UpdateShapeText(ByVal sShapeName As String, ByVal sNewText As String) As Boolean
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    UpdateShapeText = True

    For Each oS In oWS.Shapes
        If LCase(Trim(oS.Name)) = LCase(Trim(sNewText)) Then
            UpdateShapeText = False
            Exit Function
        End If
    Next

    For Each oS In oWS.Shapes
        If oS.Name = sShapeName Then
            oS.Name = sNewText
            oS.TextFrame.Characters.Text = sNewText
            Exit For
        End If
    Next

End Function