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

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