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

Sub rows()

Dim dateStart As Variant, myCell As Range
dateStart = CDate(Range("I1"))
dateStop = DateAdd("d", 1, CDate(dateStart))

Set cellStart = Range("A:A").Find(dateStart, LookIn:=xlValues)
Set cellStop = Range("A:A").Find(dateStop, LookIn:=xlValues)

If Not cellStart Or Not cellStop Is Nothing Then
Range("K1").Value = cellStart.Row
Range("K2").Value = cellStop.Row
End If

Worksheets("Èñõîäíûé ëèñò").Range(Cells(cellStart.Row, 1), Cells(cellStop.Row, 6)).Copy _
    Destination:=Worksheets("Öåëåâîé ëèñò").Range("A2:F23")

End Sub

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