Загрузка данных

Sub RenameShapesMagic()
    Dim shp As Shape
    Dim oldText As String
    Dim newText As String
    Dim changedCount As Long
    
    ' Using ChrW to safely generate Russian letters without encoding issues
    ' ChrW(1050) & ChrW(1086) & ChrW(1084) & ChrW(1085) & ChrW(1072) & ChrW(1090) & ChrW(1072) & ChrW(32) = "Комната "
    oldText = ChrW(1050) & ChrW(1086) & ChrW(1084) & ChrW(1085) & ChrW(1072) & ChrW(1090) & ChrW(1072) & ChrW(32)
    
    ' ChrW(49) & ChrW(1055) & ChrW(1086) & ChrW(1084) & ChrW(1077) & ChrW(1097) & ChrW(1077) & ChrW(1085) & ChrW(1080) & ChrW(1077) & ChrW(32) = "1Помещение "
    newText = ChrW(49) & ChrW(1055) & ChrW(1086) & ChrW(1084) & ChrW(1077) & ChrW(1097) & ChrW(1077) & ChrW(1085) & ChrW(1080) & ChrW(1077) & ChrW(32)
    
    changedCount = 0
    Application.ScreenUpdating = False
    
    For Each shp In ActiveSheet.Shapes
        If InStr(1, shp.Name, oldText, vbTextCompare) > 0 Then
            shp.Name = Replace(shp.Name, oldText, newText, 1, -1, vbTextCompare)
            changedCount = changedCount + 1
        End If
    Next shp
    
    Application.ScreenUpdating = True
    
    MsgBox "Magic done! Successfully renamed " & changedCount & " shapes.", vbInformation, "Success"
End Sub