Sub RenameSheetsBasedOnSelectedColumns()
    Dim ws As Worksheet
    Dim newName As String
    Dim oldName As String
    Dim oldNameColumn As Long, newNameColumn As Long
    Dim rng As Range, cell As Range
    Dim userWorkbook As Workbook
    Dim selectedSheet As Worksheet

    On Error Resume Next ' Включаем обработку ошибок

    ' Получаем ссылку на активную книгу пользователя
    Set userWorkbook = Application.ActiveWorkbook
    If userWorkbook Is Nothing Then
        MsgBox "Нет активной книги для выполнения макроса."
        Exit Sub
    End If

    ' Запрос у пользователя на выбор столбцов с текущими и новыми именами листов
    Set rng = Application.InputBox("Выберите столбец с текущими именами листов:", Type:=8)
    If rng Is Nothing Then
        MsgBox "Выбор столбца с текущими именами отменен или выполнен некорректно."
        Exit Sub
    End If
    oldNameColumn = rng.Column
    Set selectedSheet = rng.Worksheet

    Set rng = Application.InputBox("Выберите столбец с новыми именами листов:", Type:=8)
    If rng Is Nothing Then
        MsgBox "Выбор столбца с новыми именами отменен или выполнен некорректно."
        Exit Sub
    End If
    newNameColumn = rng.Column

    On Error GoTo 0 ' Выключаем обработку ошибок

    ' Определяем последнюю заполненную строку в выбранном столбце с текущими именами
    Set rng = selectedSheet.Columns(oldNameColumn).SpecialCells(xlCellTypeConstants)
    If rng Is Nothing Then
        MsgBox "Столбец с текущими именами листов не содержит заполненных ячеек."
        Exit Sub
    End If

    Application.ScreenUpdating = False ' Отключаем обновление экрана для улучшения производительности

    ' Цикл по каждой строке с данными
    For Each cell In rng
        oldName = Trim(cell.Value) ' Убираем пробелы в начале и конце строки
        newName = cell.Offset(0, newNameColumn - oldNameColumn).Value

        ' Проверяем, существует ли лист с текущим именем
        On Error Resume Next
        Set ws = userWorkbook.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 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