Страницы: 1
RSS
Макросы в надстройке, Переименовывание листов через надстройку
 
Здравствуйте, у меня есть макрос который переименовывает текущие листы на заданные имена, на листе в одном столбце текущие имена листов на втором новые имена и макросу нужно указать эти столбцы и он переименует эти листы, проблема в том что макрос работает в обычной книге, а я хочу запускать через надстройку, и тут он не работает, могли бы подсказать как исправить ?
Код
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

 
Евген1788, ThisWorkbook - это та книга, где расположен этот макрос.
Т.е. это надстройка.
Вот это и меняйте.
Дотошно код не читал.
 
Hugo, как правильно я не особо шарю в вба, это писал gpt, бесплатные ответы закончились у него)) а я хочу добавить в свою надстройку
 
Нужно любым способом указать какую книгу обрабатывать, я не знаю что там Вы задумали.
Может это activeworkbook, может какая другая конкретная книга...
 
в общем gpt воскрес))) если кому нужно через надстройку он исправил
Код
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
Страницы: 1
Наверх