查找现有文本框的列范围

Question

我刚刚开始使用vba for excel，我正在尝试创建一个类型的宏，它显示已存在的文本框的位置，就其开始的列和结束的列而言。我遍布堆栈和其他网站只是为了找到创建一个全新文本框并显示位置的宏。我想在该文本框中显示文本框的开始和结束位置，并希望在您移动框本身时更新它。我只是有点不知所措，因为我还不了解vba的功能。这是我正在寻找的一个例子：

我已经遇到代码创建一个文本框并在对话框中返回右下角但是无法将此信息更改为有用的东西，让我开始将非常感激。

这是我发现的代码btw：

Sub CallTheFunction()
Dim Cell As Range
Set Cell = DrawPostIt(100, 150, 250, 150, "MyTextBox1")
MsgBox Cell.Address

End Sub

Function DrawPostIt(Left As Single, Top As Single, Width As Single, _
    Height As Single, Text As String) As Range
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Left, _
        Top, Width, Height).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 192, 0) ' Yellow post-it
        .Transparency = 0
        .Solid
    End With
    Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Text
    Set DrawPostIt = Selection.BottomRightCell
End Function

提前谢谢

Answer 1

要自动更新，您只能使用SelectionChange事件之类的解决方法，因为形状没有resize事件。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Target.Parent

    Dim shp As Shape
    For Each shp In ws.Shapes   'loop through all shapes
        If shp.Type = msoTextBox Then 'that are text boxes
            'write the header cells into the text box
            shp.OLEFormat.Object.Caption = ws.Cells(1, shp.TopLeftCell.Column).text & " - " & ws.Cells(1, shp.BottomRightCell.Column).text
        End If
    Next shp
End Sub

Answer 2

使用ActiveX文本框，您可以查看reduce和TopLeftCell属性。

BottomRightCell

修改：确保您可以看到Sub Test() Dim wrkSht As Worksheet Dim shp As Shape 'ThisWorkbook is the spreadsheet that this code is in. 'Setting a reference to the worksheet means we can run this code anywhere 'and not just on the ActiveSheet. Set wrkSht = ThisWorkbook.Worksheets("Sheet1") 'This is the name of the shape as it appears in the Name box (just above cell A1). 'Name can also be found in the Selection Pane when the box is selected (`Format` ribbon for the textbox). Set shp = wrkSht.Shapes("TextBox1") 'Returns the column number and the column letter. '(Address returns something like $A$1 which can be split by the $). 'Look at how to use With... End With blocks. With shp.TopLeftCell Debug.Print .Column & " - " & Split(.Address, "$")(1) End With With shp.BottomRightCell Debug.Print .Column & " - " & Split(.Address, "$")(1) End With End Sub 窗口，以查看Immediate的结果。

Answer 3

您也可以使用矩形作为形状执行类似下面的操作，这将循环遍历列并检查其宽度，然后获取矩形的相关开始和结束，然后将标题添加到矩形中（在为了运行宏，您需要一个单独的按钮或将其指定给单击事件上的形状，这样您就可以移动形状然后单击它，它应该具有所需的效果）：

Sub foo()
LastCol = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column 'check the last column on the first row
For i = 1 To LastCol ' loop and add the width of each column
    NewWidth = NewWidth + Sheet1.Cells(1, i).Width
    If NewWidth >= ActiveSheet.Shapes.Range(Array("Rectangle 2")).Left Then Exit For
    'make sure to have a shape already set up and change the name from Rectangle 2 to whatever your shape is called
    'if the left of the rectangle falls here, stop loop
Next i

For x = LastCol To 1 Step -1
    NewRight = NewRight + Sheet1.Cells(1, x).Width
    If NewRight >= ActiveSheet.Shapes.Range(Array("Rectangle 2")).Left + ActiveSheet.Shapes.Range(Array("Rectangle 2")).Width Then Exit For
Next x
    ActiveSheet.Shapes.Range(Array("Rectangle 2")).Select 'change the name of your shape
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Sheet1.Cells(1, i).Value & " to " & Sheet1.Cells(1, LastCol - x + 1).Value  'add the text from the first column
End Sub