Loop Through Shapes in a Workbook and rename based on Location - excel

Question

Long time listener, first time caller.
Anyway, I could use a bit of help. I have a macro that adds Text Boxes, and names them "Fig Num " & ActiveSheet.Shapes.count.
Once all of these text boxes are spread through out the Workbook, I would like to rename all shapes with the name "Fig Num*", or at least the text inside them, to go in order from first page to last, top to bottom, and left to right.
Currently, my code will rename the the text boxes based on seniority. In other words, if I added a text box and it was labeled "Fig Num 3", it would still be named "Fig Num 3" whether it was on the first page or last page.
enter code here
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
---
I have a workbook example, but I'm not sure how to load it up, this being my first time and all.
Edit:
I have found a code that will do what I'm looking for, however it's a bit clunky. I also need a good way to find the last row on the sheet that contains a shape. Since the shape names are based on creation, if I insert a shape in row 35 and use the shape.count. featured below, it will skip all shapes after row 35 unless I add additional rows that bog down the code.
Most Recent Code (loops through grouped shapes):
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
Example of Workbook:

Answer 1

Rename Text Boxes
To use the ArrayList, you have to have .NET Framework 3.5 SP1 installed, even if you already have a later version (e.g. 4.7) installed.
It is assumed that each text box is an ActiveX control (not a Form control) and has a (per worksheet) unique top-left cell.
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