Sub RenameSheetsBasedOnSelectedColumns()
    Dim ws As Worksheet
    Dim newName As String
    Dim i As Long
    Dim oldNameColumn As Long, newNameColumn As Long
    Dim lastRow As Long
    Dim rng As Range, cell As Range
    
    On Error Resume Next ' Включаем обработку ошибок
    
    ' Запрос у пользователя на выбор столбцов с текущими и новыми именами листов
    oldNameColumn = Application.InputBox("Выберите столбец с текущими именами листов:", Type:=8).Column
    If oldNameColumn = 0 Then
        MsgBox "Выбор столбца с текущими именами отменен или выполнен некорректно."
        Exit Sub
    End If
    
    newNameColumn = Application.InputBox("Выберите столбец с новыми именами листов:", Type:=8).Column
    If newNameColumn = 0 Then
        MsgBox "Выбор столбца с новыми именами отменен или выполнен некорректно."
        Exit Sub
    End If
    
    On Error GoTo 0 ' Выключаем обработку ошибок
    
    ' Определяем последнюю заполненную строку в выбранном столбце с текущими именами
    Set rng = Columns(oldNameColumn).SpecialCells(xlCellTypeConstants)
    If rng Is Nothing Then
        MsgBox "Столбец с текущими именами листов не содержит заполненных ячеек."
        Exit Sub
    End If
    lastRow = rng.Cells(rng.Cells.Count).Row
    
    Application.ScreenUpdating = False ' Отключаем обновление экрана для улучшения производительности
    
    ' Цикл по каждой строке с данными
    For Each cell In rng
        i = cell.Row
        
        ' Получаем текущее и новое имя
        oldName = Trim(Cells(i, oldNameColumn).Value) ' Убираем пробелы в начале и конце строки
        newName = Cells(i, newNameColumn).Value
        
        ' Проверяем, существует ли лист с текущим именем
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(oldName)
        On Error GoTo 0
        
        If Not ws Is Nothing Then
            ' Если лист существует, переименовываем его
            ws.Name = newName
        Else
            ' Если лист не существует, выводим сообщение об ошибке
            MsgBox "Лист с именем '" & oldName & "' не найден."
        End If
    Next cell
    
    Application.ScreenUpdating = True ' Включаем обновление экрана обратно
    
    MsgBox "Процесс переименования завершен."
End Sub

Sub InsBeforeNewName()
  Dim r&: r = 10
  Do While Not IsEmpty(Cells(r, 5))
    If Cells(r, 5) <> Cells(r - 1, 5) Then Rows(r).Insert: r = r + 2 Else r = r + 1
  Loop
End Sub

Sub dsd()
Dim i As Long
Dim n As Long
Dim lr As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 6 Step -1
    If Cells(i, 1) = Cells(i - 1, 1) Then
        k = k + 1
    Else
        For n = 1 To 1
        Range(Cells(i, n), Cells(i + k, n)).Merge
        Next n
        k = 0
    End If
Next i

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub Split_By_Rows()   
 Dim cell As Range, n As Integer
     Set cell = ActiveCell
     For i = 1 To Selection.Rows.Count
        ar = Split(cell, Chr(10))         'делим текст по переносам в массив
        n = UBound(ar)                    'определяем кол-во фрагментов
        cell.Offset(1, 0).Resize(n, 1).EntireRow.Insert             'вставляем пустые строки ниже
        cell.Resize(n + 1, 1) = WorksheetFunction.Transpose(ar)     'вводим в них данные из массива
        Set cell = cell.Offset(n + 1, 0)                            'сдвигаемся на следующую ячейку
    Next i
End Sub

Sub InsertPictureByVal()
    Dim sPicsPath As String
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim llastr As Long, lr As Long
    Dim oShp As Shape
    Dim zoom As Double
    
    'выбираем путь к папке с картинками
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку с картинками"       'заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear                              'очищаем установленные ранее типы файлов
        .InitialFileName = ThisWorkbook.Path        'назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons  'вид диалогового окна
        If .Show = 0 Then Exit Sub               'показываем диалог
        sPicsPath = .SelectedItems(1) 'считываем путь к папке
    End With
    '   если путь надо указать статичный - вместо диалога прописываем одну строку
    '   sPicsPath = "C:\images\"
    
    
    'проверяем, есть ли слеш после пути к папке
    'если нет - добавляем, иначе путь к картинке будет неверный
    If Right(sPicsPath, 1) <> Application.PathSeparator Then
        sPicsPath = sPicsPath & Application.PathSeparator
    End If
    'определяем последнюю ячейку по столбцу с именами картинок
    llastr = Cells(Rows.Count, 2).End(xlUp).Row
    'если кроме шапки в столбце с именами картинок ничего нет
    If llastr < 2 Then
        Exit Sub
    End If
    'цикл по столбцу с именами картинок
    For lr = 2 To llastr
        sPicName = Cells(lr, 2).Value
        'проверяем наличие картинки в папке
        sPFName = sPicsPath & sPicName
        If Dir(sPFName, 16) <> "" And sPicName <> "" Then
            'в эту ячейку вставляем картинку
            With Cells(lr, 3)
                
                'задаем картинке уникальный адрес,
                'привязанный к адресу ячейки
                sSpName = "_" & .Address(0, 0) & "_autopaste"
                'если картинка уже есть - удаляем её
                Set oShp = Nothing
                On Error Resume Next
                Set oShp = ActiveSheet.Shapes(sSpName)
                If Not oShp Is Nothing Then
                    oShp.Delete
                End If
                On Error GoTo 0
                'вставляем выбранную картинку
                Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
                'определяем размеры картинки в зависимости от размера ячейки
                zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
                oShp.Height = oShp.Height * zoom - 2
                'переименовываем вставленную картинку(чтобы потом можно было заменить)
                oShp.Name = sSpName
            End With
        End If
    Next
End Sub

Sub InsertPic(Optional ByVal rngPic As Range, Optional pathPic As String, Optional ByVal namePic As String)
If rngPic Is Nothing Then Set rngPic = ActiveCell
If pathPic = "" Then pathPic = rngPic.Value
On Error Resume Next
With rngPic.Parent.Pictures.Insert(pathPic)
  If namePic <> "" Then .Name = namePic
  .Top = rngPic.Top
  .Height = rngPic.Height
End With
On Error GoTo 0
End Sub

Sub InsertPictures()
InsertPic
End Sub