具有相对定位的 VBA 形状

Question

我有这段代码，但它没有按我的意愿工作。 这就是我要的： - 如果我在单元格 A1、A2 或 A3（在工作表 1 中）中写了一些东西，则会在工作表（2）中创建一个文本框。这可行，但现在我希望在单元格 B1、B2、B3 中更改文本框的位置。 我尝试使用下面的代码来做到这一点，但我认为我定义Range("B" & CStr(i)) 的方式可能存在问题，因为当我只使用 B1 时它可以工作。 我需要更改两个代码以不同的方式做两件事： 1- 如果我在 B1 "cliente" 中写入，我希望在 toppos=150 中创建带有 A1 文本的 texbox，如果我将其更改为 "financeiro"，我希望在 toppos=20 中创建 texbox。

2- 如果 B1 和 B2 写有“fianceiro”，我希望与 A1 和 A2 相关的文本框彼此相邻。 有人能帮我吗？ 谢谢

所以这就是我想要的： - 使用工作表 2 上单元格 A1 到 A3 的内容创建的文本框； - 如果我更改内容，则应更新文本框的内容，如果我删除该值，则应删除文本框； - 文本框的位置应该随着我在 B 列中选择的选项而改变。我希望工作表（2）有 4 个“切片”，第一个是选项“financeiro”，所以所有与该切片相关的文本框页面应位于工作表中的特定位置，例如位置 20，另一方面，如果该文本框来自选项“cliente”，则文本框应位于与“cliente”相关的切片中，位置 150。 -B 列中的每个选项也可能有多个文本框，因此我希望同一选项中的文本框并排显示。

---

Sub removercaixas(strName As String)
    Dim shp As Shape
    For Each shp In Worksheets(2).Shapes
        If shp.Type = msoTextBox And shp.Name = strName Then shp.Delete
    Next shp
End Sub

Sub criarcaixastexto(strName As String)
    Dim wsActive As Worksheet
    Dim box As Shape

    Set wsActive = Worksheets(2)

    Dim leftpos As Long
    Dim toppos As Long
    Dim i As Long

    For i = 1 To 3

        If Worksheets(1).Range("B" & CStr(i)).Value = "financeiro" Then
            toppos = 20
        ElseIf Worksheets(1).Range("B" & CStr(i)).Value = "cliente" Then
            toppos = 150
        ElseIf Worksheets(1).Range("B" & CStr(i)).Value = "processos internos" Then
            toppos = 250
        Else:
            toppos = 350
        End If
    Next i

    Select Case strName
        Case Is = "$A$1"
            leftpos = 50
        Case Is = "$A$2"
            leftpos = 200
        Case Is = "$A$3"
            leftpos = 350

    End Select

    Set box = wsActive.Shapes.AddTextbox(msoTextOrientationHorizontal, leftpos, toppos, 100, 50)
    box.TextFrame.Characters.Text = Worksheets(1).Range(strName).Value
    box.Name = strName
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Select Case Target.Address
        Case "$A$1", "$A$2", "$A$3"
            removercaixas (Target.Address)
            If Len(Target) > 0 Then criarcaixastexto (Target.Address)
        Case Else
            Exit Sub
    End Select
End Sub

Answer 1

我不确定 OP 的某些逻辑或他到底想要完成什么。如果需要，我将创建一个函数来创建文本框，并返回对它的引用，而不是添加和删除文本框。

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Or Not Sh.Index = 1 Or Len(Target) = 0 Then Exit Sub
    Dim box As Shape

    If Not Intersect(Target, Range("B1:B3")) Is Nothing Then
        Set box = getCaixas(Worksheets(2), Target.Offset(0, -1).Address)
        Select Case Target.Value
            Case Is = "financeiro"
                box.Top = 20
            Case Is = "cliente"
                box.Top = 150
            Case Is = "processos internos"
                box.Top = 250
        End Select
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim box As Shape
    If Target.Count > 1 Or Not Sh.Index = 1 Or Len(Target) = 0 Then Exit Sub

    If Not Intersect(Target, Range("A1:A3")) Is Nothing Then
        Set box = getCaixas(Worksheets(2), Target.Address)
        Select Case Target.Address
            Case Is = "$A$1"
                box.Left = 50
            Case Is = "$A$2"
                box.Left = 200
            Case Is = "$A$3"
                box.Left = 350
        End Select
        box.TextFrame.Characters.Text = Target.Value
    End If
End Sub

Function getCaixas(ws As Worksheet, CaixasName As String) As Shape
    Dim box As Shape
    On Error Resume Next
    Set box = ws.Shapes(CaixasName)
    If Err.Number <> 0 Then
        Set box = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 100, 50)
        box.Name = CaixasName
    End If
    On Error GoTo 0
    Set getCaixas = box
End Function