Private Sub Worksheet_Change(ByVal Target As Range)
    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Range("B:B")) ' Отслеживаем изменения только в столбце B
    
    If Not AffectedRange Is Nothing Then
        Application.EnableEvents = False ' Отключить события, чтобы избежать рекурсии
        Call DeleteExistingCopies ' Удалить предыдущие копии
        Call ArrangeShapes ' Создать новые копии
        Application.EnableEvents = True ' Включить события обратно
    End If
End Sub

Sub DeleteExistingCopies()
    Dim ExistingShape As Shape
    Dim i As Integer
    
    ' Проход по всем фигурам на листе
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        Set ExistingShape = ActiveSheet.Shapes(i)
        ' Проверка на префикс "copy_shape"
        If Left(ExistingShape.Name, 10) = "copy_shape" Then
            ExistingShape.Delete
        End If
    Next i
End Sub

Sub ArrangeShapes()
    Dim SourceRange As Range
    Dim ShapeName As String
    Dim i As Integer
    Dim OriginalShape As Shape
    Dim CopiedShape As Object
    Dim TargetRange As Range
    Dim TopPosition As Double
    
    ' Задайте диапазон, где содержатся названия фигур
    Set SourceRange = Worksheets("Лист1").Range("B1:B10")
    
    ' Задайте диапазон, куда будут выставляться фигуры
    Set TargetRange = Worksheets("Лист1").Range("D1")
    
    ' Очищаем столбец D перед размещением
    TargetRange.EntireColumn.ClearContents
    
    ' Удалить существующие копии фигур, если они есть
    DeleteExistingCopies
    
    ' Определить начальную вертикальную позицию
    TopPosition = TargetRange.Top
    
    ' Проход по каждой строке в исходном диапазоне
    For i = 1 To SourceRange.Rows.Count
        ShapeName = SourceRange.Cells(i, 1).Value
        
        ' Найти оригинальную фигуру по имени
        Set OriginalShape = FindShapeByName(ShapeName)
        
        If Not OriginalShape Is Nothing Then
            On Error Resume Next
            ' Создать копию фигуры, если метод Duplicate существует
            Set CopiedShape = Application.Run("DuplicateShape", OriginalShape)
            On Error GoTo 0
            
            If Not CopiedShape Is Nothing Then
                ' Разместить копию фигуры
                Call PlaceShapeInCell(CopiedShape, TargetRange.Cells(i, 1), TopPosition)
                
                ' Изменить имя копии фигуры
                Dim ShapeNumber As String
                ShapeNumber = Format(i, "000")
                CopiedShape.Name = "copy_shape" & ShapeNumber
                
                ' Обновить вертикальную позицию для следующей фигуры
                TopPosition = TopPosition + CopiedShape.Height ' Высота фигуры
            End If
        End If
    Next i
End Sub

Function FindShapeByName(ShapeName As String) As Shape
    Dim FoundShape As Shape
    
    ' Поиск фигуры по имени
    On Error Resume Next
    Set FoundShape = Worksheets("Лист1").Shapes(ShapeName)
    On Error GoTo 0
    
    Set FindShapeByName = FoundShape
End Function

Sub PlaceShapeInCell(TargetShape As Object, TargetCell As Range, TopPos As Double)
    ' Выставить фигуру в соответствующей ячейке
    TargetShape.Top = TopPos
    TargetShape.Left = TargetCell.Left + (TargetCell.Width - TargetShape.Width) / 2
End Sub

Function DuplicateShape(ShapeToDuplicate As Shape) As Object
    On Error Resume Next
    Set DuplicateShape = ShapeToDuplicate.Duplicate
    On Error GoTo 0
End Function

Sub ArrangeShapes()
    Dim SourceRange As Range
    Dim ShapeName As String
    Dim i As Integer
    Dim OriginalShape As Shape
    Dim TargetRange As Range
    Dim TopPosition As Double
    Dim DestinationSheet As Worksheet
    
    ' Укажите лист, на который нужно вставлять фигуры
    Set DestinationSheet = Worksheets("Лист1")
    
    ' Определите диапазон, в котором находятся названия фигур
    Set SourceRange = DestinationSheet.Range("B1:B10")
    
    ' Определите диапазон, куда будут размещаться фигуры
    Set TargetRange = DestinationSheet.Range("D1")
    
    ' Очистите столбец D перед размещением фигур
    TargetRange.EntireColumn.ClearContents
    
    ' Удалите существующие копии фигур, если они есть
    DeleteExistingCopies
    
    ' Установите начальную вертикальную позицию
    TopPosition = TargetRange.Top
    
    ' Проход по каждой строке в исходном диапазоне
    For i = 1 To SourceRange.Rows.Count
        ShapeName = SourceRange.Cells(i, 1).Value
        
        ' Найти оригинальную фигуру по имени на "Лист2"
        Set OriginalShape = FindShapeByNameOnSheet2(ShapeName)
        
        If Not OriginalShape Is Nothing Then
            ' Копировать оригинальную фигуру в буфер обмена
            OriginalShape.CopyPicture
            DestinationSheet.Paste Destination:=TargetRange.Cells(i, 1)
            
            ' Получить вставленную фигуру
            Dim CopiedShape As Shape
            Set CopiedShape = DestinationSheet.Shapes(DestinationSheet.Shapes.Count)
            
            ' Разместить вставленную фигуру в правильном месте
            Call PlaceShapeInCell(CopiedShape, TargetRange.Cells(i, 1), TopPosition)
            
            ' Переименовать вставленную фигуру
            Dim ShapeNumber As String
            ShapeNumber = Format(i, "000")
            CopiedShape.Name = "copy_shape" & ShapeNumber
            
            ' Обновить вертикальную позицию для следующей фигуры
            TopPosition = TopPosition + CopiedShape.Height
        End If
    Next i
End Sub

Sub DeleteExistingCopies()
    Dim ExistingShape As Shape
    Dim i As Integer
    
    ' Проход по всем фигурам на листе
    For i = Worksheets("Лист1").Shapes.Count To 1 Step -1
        Set ExistingShape = Worksheets("Лист1").Shapes(i)
        ' Проверка на префикс "copy_shape"
        If Left(ExistingShape.Name, 10) = "copy_shape" Then
            ExistingShape.Delete
        End If
    Next i
End Sub

Function FindShapeByNameOnSheet2(ShapeName As String) As Shape
    Dim FoundShape As Shape
    
    ' Поиск фигуры по имени на "Лист2"
    On Error Resume Next
    Set FoundShape = Worksheets("Лист2").Shapes(ShapeName)
    On Error GoTo 0
    
    Set FindShapeByNameOnSheet2 = FoundShape
End Function

Sub PlaceShapeInCell(TargetShape As Object, TargetCell As Range, TopPos As Double)
    ' Выставить фигуру в соответствующей ячейке
    TargetShape.Top = TopPos
    TargetShape.Left = TargetCell.Left + (TargetCell.Width - TargetShape.Width) / 2
End Sub

Function DuplicateShape(ShapeToDuplicate As Shape) As Object
    ' Попытаться создать копию фигуры, проверив на наличие метода Duplicate
    On Error Resume Next
    Set DuplicateShape = ShapeToDuplicate.Duplicate
    On Error GoTo 0
End Function

TextBox1.Text = Range("'Книга1'!A1").Value
TextBox1.Value = Format(TextBox1.Text, "hh:nn")

function Signature( $params, $api_key )
{
$params = array(
    'timestamp' => '1501052684',
    'login'     => 'YourLogin',
    'phone'     => '0',
    'sender'    => 'smstest'
    'text'      => 'Long text'
);

//сортировка по алфавиту
    ksort( $params );
    reset( $params );
 
//преобразовывание результата сначала в строку, потом в md хеш
    return md5( implode( $params ) . $api_key );
}

Private Sub UserForm_Initialize()
        Dim FormName
        FormName = UserForm.Name
        
        Dim FormArray As Variant
        FormArray = Array(Add.Name, Edit.Name, Del.Name)
       
        Procedure FormName, FormArray
End Sub

Sub Procedure (FormName, FormArray)
    Dim i As Integer
    For i = 0 To 2
    FormName.Controls(FormArray(i)).BackColor = RGB(333, 111, 222)
    Next
End Sub

Dim MyArray aS Variable
Dim I As Intager

en = MyArray(Image1.Name, Image2.Name, Image3.Name)
For I=0 To en(I)
       en(I)&".BackColor" = RGB (255, 255, 255)
Next I