查找现有文本框的列范围

我刚刚开始使用Excel的VBA，我试图创build一个macros的某种types，显示已经存在的文本框的位置，以哪一列开始，哪一列结束。 我查看了所有堆栈和其他网站，只查找创build全新文本框并显示位置的macros。 我只想在该文本框中显示文本框的开始和结束位置，并希望在您移动框自身时进行更新。 我只是有点不知所措，因为我还不了解vba的function。 这是我正在寻找的一个例子：

我碰到代码创build一个文本框，并在对话框中返回右下angular，但还没有能够改变这个信息成为有用的东西，让我开始将不胜感激。

这是我发现顺便说一句：

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事件的解决方法，因为不存在形状的大小调整事件。

 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文本框，您可以查看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窗口可见，以查看Debug.Print的结果。

Answer 3

你也可以做一个矩形作为一个形状做下面的东西，这将循环通过列，并检查其宽度，然后得到相关的矩形开始和结束，然后将标题添加到矩形（为了运行macros你将需要一个单独的button或将其分配给单击事件的形状，所以你可以移动的形状，然后点击它，它应该有所需的效果）：

 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