Apply the same code, but in different columns

Rename Shapes

Main

Sub RenameShapes()
    
    ' Define constants.
    Const OLD_NAMES_ADDRESS As String = "AZ33:EU33" ' must be a row
    Const NEW_NAMES_ROW As Long = 30
    Const CHANGE_OLD_TO_NEW As Boolean = True
    
    ' Reference the sheet (assumes it's a worksheet, not a chart).
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the sheet's Shapes collection.
    ' Exit if no shapes found.
    Dim shps As Shapes: Set shps = ws.Shapes
    If shps.Count = 0 Then
        MsgBox "There are no shapes in sheet """ & ws.Name & """!", _
            vbExclamation
        Exit Sub
    End If
    
    ' Reference the single-row ranges, the cells with actual (old) names
    ' and the corresponding cells (cells in the same columns) with new names.
    Dim org As Range: Set org = ws.Range(OLD_NAMES_ADDRESS)
    Dim nrg As Range: Set nrg = org.EntireColumn.Rows(NEW_NAMES_ROW)
    
    ' Return the values of the ranges in 2D one-based (single-row) arrays.
    Dim oData() As Variant: oData = GetRange(org)
    Dim nData() As Variant: nData = GetRange(nrg)
    
    ' Declare additional variables.
    Dim OldValue As Variant, NewValue As Variant
    Dim OldName As String, NewName As String, MsgStr As String
    Dim Col As Long
    Dim HaveBothChars As Boolean, WasShapeRenamed As Boolean
    Dim WasAnyShapeRenamed As Boolean, HasRenameFailed As Boolean
    
    ' Loop through the columns of the arrays applying the following logic:
    ' Check if both values have characters, i.e., they are not blank
    ' or contain error values.
    ' If they don't, ignore the entries.
    ' If they do, check whether the 'old' shape exists AND the new
    ' name is NOT taken.
    ' If both conditions are met, attempt to rename the shape.
    ' If one or both conditions are NOT met, OR if the renaming attempt failed,
    ' 'log' this information (mentioning both names) in the 'message string'.
    For Col = 1 To org.Columns.Count
        HaveBothChars = False
        OldValue = oData(1, Col)
        If HasChars(OldValue) Then
            NewValue = nData(1, Col)
            If HasChars(NewValue) Then HaveBothChars = True
        End If
        If HaveBothChars Then ' both have chars; proceed!
            WasShapeRenamed = False
            OldName = CStr(OldValue)
            NewName = CStr(NewValue)
            If IsNameTaken(shps, OldName) Then
                If Not IsNameTaken(shps, NewName) Then
                    ' Note that the 'RenameObject' procedure sets
                    ' the 'WasShapeRenamed' flag (passed by reference 'ByRef').
                    RenameObject shps(OldName), NewName, WasShapeRenamed
                End If
            End If
            If WasShapeRenamed Then
                If CHANGE_OLD_TO_NEW Then oData(1, Col) = nData(1, Col)
                WasAnyShapeRenamed = True
            Else
                MsgStr = MsgStr & vbLf & """" & OldName & """ to """ & NewName
                HasRenameFailed = True
            End If
        'Else ' one or both don't have chars; ignore!
        End If
    Next Col
                
    ' Optionally, replace old cell values with new ones.
    If WasAnyShapeRenamed And CHANGE_OLD_TO_NEW Then org.Value = oData
                
    ' Finish building the 'message string'.
    If HasRenameFailed Then MsgStr = vbLf & vbLf _
        & "The following shapes could not be renamed:" & MsgStr
    MsgStr = IIf(WasAnyShapeRenamed, "S", "No s") & "hapes renamed." & MsgStr
    
    ' Display the message.
    MsgBox MsgStr, IIf(WasAnyShapeRenamed And Not HasRenameFailed, _
        vbInformation, vbExclamation)

End Sub

Help

' Returns the values (of the first area) of a range in a 2D one-based array.
Function GetRange(ByVal rg As Range) As Variant
    If rg Is Nothing Then Exit Function
    With rg.Areas(1)
        If rg.Cells.CountLarge = 1 Then
            Dim Data() As Variant: ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = .Value: GetRange = Data
        Else
            GetRange = .Value
        End If
    End With
End Function

' Returns a boolean indicating whether a value has a length,
' i.e., whether it can be converted to a string with a length greater than zero.
Function HasChars(ByVal Value As Variant) As Boolean
    Dim CharsCount As Long:
    On Error Resume Next
        CharsCount = Len(Value)
    On Error GoTo 0
    HasChars = (CharsCount > 0)
End Function

' Returns a boolean indicating whether an object by name
' already exists in a collection of objects.
Function IsNameTaken( _
    ByVal objectsCollection As Object, _
    ByVal ObjectName As String) _
As Boolean
    Dim obj As Object:
    On Error Resume Next
        Set obj = objectsCollection(ObjectName)
        IsNameTaken = (Err.Number = 0)
    On Error GoTo 0
End Function

' Renames an object.
' Attempts to rename an object and sets a Boolean ('WasObjectRenamed')
' passed by reference indicating whether the attempt was successful.
' This Boolean variable (in this case 'WasShapeRenamed')
' must be declared in the calling procedure and passed as the 3rd argument.
Sub RenameObject( _
        ByRef obj As Object, _
        ByVal NewObjectName As String, _
        ByRef WasObjectRenamed As Boolean)
    On Error Resume Next
        obj.Name = NewObjectName
        WasObjectRenamed = (Err.Number = 0) ' (obj.Name = NewObjectName) '
    On Error GoTo 0
End Sub

This macro renames shapes on Sheet1 based on a mapping list in range AZ33:EU33.

It checks each entry:

1. Skips blank cells.
2. Compares the proposed new name (3 rows above) with the current name.
3. Verifies the shape with the current name exists.
4. Ensures the new name is not already in use.
5. If valid, renames the shape and updates the cell.

Finally, it reports how many shapes were successfully renamed.

Option Explicit

Sub Demo()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, iCnt As Long
    Dim Shp As Shape, c As Range
    
    ' range containing shape names (adjust if needed)
    Const SHP_LIST = "AZ33:EU33"
    
    ' specify sheet explicitly instead of using ActiveSheet
    Set ws = Sheets("Sheet1")
    
    ' iterate through each cell in SHP_LIST
    For Each c In ws.Range(SHP_LIST)
        ' skip blank cells
        If Len(Trim(c.Value)) > 0 Then
            ' check if proposed name differs from current
            If Not c.Value = c.Offset(-3).Value Then
                ' confirm the shape with old name exists
                If ShpExist(c.Value, ws) Then
                    ' proposed new name (3 rows above)
                    With c.Offset(-3)
                        ' if proposed new name already exists
                        If ShpExist(.Value, ws) Then
                            MsgBox "Shape name " & .Value & " already exists. Skipped."
                        Else
                            ' rename shape
                            ws.Shapes(c.Value).Name = .Value
                            ' update cell with new name
                            c.Value = .Value
                            ' increment counter
                            iCnt = iCnt + 1
                        End If
                    End With
                End If
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Renamed " & iCnt & " shapes."
End Sub



' Helper function to verify whether the shape exists.
Function ShpExist(ShpName As String, Optional Sht As Worksheet) As Boolean
    Dim Shp As Shape
    If Sht Is Nothing Then Set Sht = ActiveSheet
    On Error Resume Next
    Set Shp = Sht.Shapes(ShpName)
    On Error GoTo 0
    ShpExist = Not Shp Is Nothing
End Function

If your current works as you want for BG column, it's enough to parametrize your current subroutine by putting column index as parameter and then simply call it in a loop.

Here's your code adjusted accordingly:

Sub ChangeName(colIndex As Long)
    ' this needs to be updated to accept column as param, not hardcode as BG
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim cellContent As String
    Dim shp As shape
    
    Set ws = ActiveSheet
    
    cellContent = ws.Cells(33, colIndex).Value  ' Shape's current name
    
    On Error Resume Next ' Handle cases where the shape might not exist
    Set shp = ws.Shapes(cellContent)
    On Error GoTo 0
    
    If Not shp Is Nothing Then
        shp.Select ' Select the found shape
    End If
    
    shp.Name = ws.Cells(30, colIndex).Value
    On Error GoTo 0
    
    ws.Cells(33, colIndex).Value = ws.Cells(30, colIndex).Value
    
    Application.ScreenUpdating = True
End Sub

Sub ChangeForEachColumn()
    ' Apply ChangeName for columns AZ through EU
    Dim ws As Worksheet
    Dim col As Long
    
    Set ws = ActiveSheet
    
    For col = ws.Range("AZ1").Column To ws.Range("EU1").Column
        Call ChangeName(col)
    Next col
End Sub

just "encapsule" your code that processes a cell into a sub accepting the cell reference and the row offset to the corresponding value as parameters:

Sub ProcessOneShape(cell As Range, rowOffset As Long)

    With cell
        On Error Resume Next ' Handle cases where the shape might not exist
            Dim shp As Shape
                Set shp = .Parent.Shapes(CStr(.Value))
        On Error GoTo 0
    
        If Not shp Is Nothing Then
            shp.Name = .Offset(rowOffset).Value
            .Value = .Offset(rowOffset).Value
        End If        
    End With
           
End Sub

and call it from your main code inside a loop through the wanted range

Sub ProcessShapes()

    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
        Set ws = ActiveSheet
    
    Dim cell As Range
        With ws.Range("AZ33:EU33") ' reference wanted range
            For Each cell In .SpecialCells(xlCellTypeConstants) ' loop through not empty cells of referenced range
                ProcessOneShape cell, -3
            Next
        End With
    
    Application.ScreenUpdating = True
    
End Sub