循环工作簿中的形状并根据位置重命名

Question

我有一个添加文本框的宏，并将其命名为

"Fig Num " & ActiveSheet.Shapes.Count

。

一旦这些文本框遍布整个工作簿，我想重命名所有名为“Fig Num*”的形状，或者至少重命名其中的文本，按照从第一个工作表到最后一个工作表、从上到下的顺序，从左到右。

我的代码根据资历重命名文本框。换句话说，如果我添加一个文本框并将其标记为“Fig Num 3”，那么无论它是在第一个工作表还是最后一个工作表上，它仍然会被命名为“Fig Num 3”。

Sub Loop_Shape_Name()

Dim sht As Worksheet
Dim shp As Shape
Dim i As Integer
Dim Str As String

i = 1

For Each sht In ActiveWorkbook.Worksheets

    For Each shp In sht.Shapes
        If InStr(shp.Name, "Fig Num ") > 0 Then                              
            sht.Activate
            shp.Select
            shp.Name = "Fig Num"
        End If
    Next shp
     
    For Each shp In sht.Shapes
        If InStr(shp.Name, "Fig Num") > 0 Then
            sht.Activate
            shp.Select
            shp.Name = "Fig Num " & i
            Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
              "FIG " & i
            i = i + 1
        End If
    Next shp
        
Next sht
End Sub

我找到了可以实现我正在寻找的功能的代码，但是它有点笨拙。我还需要一种好方法来找到包含形状的工作表上的最后一行。由于形状名称是基于创建的，因此如果我在第 35 行中插入一个形状并使用下面的

Shape.Count

，它将跳过第 35 行之后的所有形状，除非我添加其他行导致代码陷入困境。

最新代码（循环分组形状）：

Private Sub Rename_FigNum2()
 
'Dimension variables and data types
Dim sht As Worksheet
Dim shp As Shape
Dim subshp As Shape
Dim i As Integer
Dim str As String
Dim row As Long
Dim col As Long
Dim NextRow As Long
Dim NextRow1 As Long
Dim NextCol As Long
Dim rangex As Range
Dim LR As Long

i = 1

'Iterate through all worksheets in active workbook
For Each sht In ActiveWorkbook.Worksheets
    If sht.Visible = xlSheetVisible Then
        LR = Range("A1").SpecialCells(xlCellTypeLastCell).row + 200
    
        If sht.Shapes.Count > 0 Then
            With sht
                NextRow1 = .Shapes(.Shapes.Count).BottomRightCell.row + 200
                'NextCol = .Shapes(.Shapes.Count).BottomRightCell.Column + 10
            End With
    
            If LR > NextRow1 Then
                NextRow = LR
            Else
                NextRow = NextRow1
            End If
        End If

        NextCol = 15
     
        Set rangex = sht.Range("A1", sht.Cells(NextRow, NextCol))
    
        For row = 1 To rangex.Rows.Count
            For col = 1 To rangex.Columns.Count
   
                For Each shp In sht.Shapes
                    If shp.Type = msoGroup Then
                        For Each subshp In shp.GroupItems
                            If Not Intersect(sht.Cells(row, col), subshp.TopLeftCell) Is Nothing Then
                                If InStr(subshp.Name, "Fig Num") > 0 Then
                                    subshp.Name = "Fig Num " & i
                                    subshp.TextFrame2.TextRange.Characters.Text = _
                                      "FIG " & i
                                    i = i + 1
                                End If
                            End If
                        Next subshp 
            
                    Else
                        If Not Intersect(sht.Cells(row, col), shp.TopLeftCell) Is Nothing Then
                            If InStr(shp.Name, "Fig Num ") > 0 Then
                                shp.Name = "Fig Num " & i
                                shp.TextFrame2.TextRange.Characters.Text = _
                                  "FIG " & i
                                i = i + 1
                            End If
                        End If
                        
                    End If
                Next shp
                
            Next col
        Next row
    End If
    
Next sht

End Sub

作业簿示例：

Answer 1

重命名文本框

• 要使用

  ArrayList

  ，您必须安装

  .NET Framework 3.5 SP1

  ，即使您已经安装了更高版本（例如

  4.7

  ）。
• 假设每个文本框都是一个

  ActiveX

  控件（不是

  Form

  控件），并且（每个工作表）都有一个唯一的左上角单元格。

Option Explicit

Sub RenameTextBoxes()
    
    Const oTypeName As String = "TextBox" ' OLEObject Type Name
    Const fPattern As String = "Fig Num " ' Find Pattern (Unsorted)
    Const tPattern As String = "Dummy" ' Temporary Pattern
    Const nPattern As String = "Fig Num " ' New Pattern (Sorted)
    Const ByRows As Boolean = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim ws As Worksheet
    Dim ole As OLEObject
    Dim Key As Variant
    Dim n As Long
    Dim r As Long
    Dim Coord As Double
    Dim tName As String
    
    For Each ws In wb.Worksheets
        
        arl.Clear
        dict.RemoveAll
        
        For Each ole In ws.OLEObjects
            If TypeName(ole.Object) = oTypeName Then
                If InStr(1, ole.Name, fPattern, vbTextCompare) = 1 Then
                    n = n + 1
                    If ByRows Then
                        Coord = GetNumericByRows(ole.TopLeftCell)
                    Else
                        Coord = GetNumericByColumns(ole.TopLeftCell)
                    End If
                    arl.Add Coord
                    tName = tPattern & n
                    ole.Name = tName
                    dict(Coord) = tName
                End If
            End If
        Next ole
        
        arl.Sort
        
        For Each Key In arl
            r = r + 1
            ws.OLEObjects(dict(Key)).Name = nPattern & r
            'Debug.Print nPattern & r, Key, dict(Key)
        Next Key
    
    Next ws
    
End Sub


Function GetNumericByColumns( _
    ByVal OneCellRange As Range) _
As Double
    If OneCellRange Is Nothing Then Exit Function
    With OneCellRange.Cells(1)
        GetNumericByColumns = Val(.Column & "." & Format(.Row, "000000#"))
    End With
End Function

Function GetNumericByRows( _
    ByVal OneCellRange As Range) _
As Double
    If OneCellRange Is Nothing Then Exit Function
    With OneCellRange.Cells(1)
        GetNumericByRows = Val(.Row & "." & Format(.Column, "0000#"))
    End With
End Function


' Modify the range address to see what the 'GetNumeric' functions are all about.
Sub GetNumericTEST()
    Dim cCell As Range: Set cCell = Sheet1.Range("XFD1048576")
    Debug.Print GetNumericByColumns(cCell)
    Debug.Print GetNumericByRows(cCell)
End Sub