Последовательное переименование листов - VBA

Формулировка задачи:

Приветствую! Имеется макрос:

Sub Переименовать ()
 
Dim б
Windows("НаименованиеКниги1.xls").Activate
б = ActiveSheet.Name
Windows("НаименованиеКниги2.xls").Activate
ActiveSheet.Name = б
 
Sheets.Add After:=Sheets(Sheets.Count)
 
End Sub

Работает корректно: переименовывает лист в книге2 как лист в книге1 и добавляет лист в книгу2. Однако при запуске с помощью макроса:

Sub ДляВсехЛистов ()
 
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
Переименовать
Next
 
End Sub

выводится ошибка "1004": "Нельзя присвоить листу имя, совпадающее с именем другого листа, библиотеки или книги, на которую ссылается VBA" Причём ошибка выходит после того как один раз выполнен макрос "переименовать". Что должно получиться: При запуске макрос копирует наименование листа 1 в книге 1 и заменяет наименование листа в книге 2 на наименование листа 1 книги 1, затем создает в книге 2 лист 2. Переходит в книге 1 на лист 2 и процедура повторяется. Так происходит до последнего листа в книге 1. Просьба помочь решить данную проблему.

Решение задачи: «Последовательное переименование листов»

textual
                            Листинг программы 
                        

                            Option Explicit
 
Sub tt()
    Dim wb1 As Workbook, wb2 As Workbook, sh As Worksheet
 
    Set wb1 = Workbooks("НаименованиеКниги1.xls")
    Set wb2 = Workbooks("НаименованиеКниги2.xls")
 
    For Each sh In wb1.Worksheets
        If Not SheetExists(wb2, sh.Name) Then
            With wb2: .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sh.Name: End With
            Call Пересобрать(sh, wb2.Sheets(sh.Name))
        End If
    Next
 
End Sub
 
Function SheetExists(wb As Workbook, SheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function
 
 
Sub Пересобрать(sh1 As Object, sh2 As Object)
    sh2.[a1:cv100].Formula = sh1.[a1:cv100].Formula 'тут диапазон нужно бы определять динамически...
 
    sh1.Cells.Copy
    sh2.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                           SkipBlanks:=False, Transpose:=False
    sh2.Cells.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _
                           SkipBlanks:=False, Transpose:=False
End Sub
                        