Как скопировать листы с переименованием по списку?

Question

Я пытаюсь использовать приведенный ниже код, чтобы скопировать «главный» рабочий лист с переименованием в соответствии со значениями в рабочем листе «Список», который работает только один раз.

Если я попытаюсь запустить макрос снова, переименование не произойдет.

Ошибка выполнения '1004':
имя уже занято. попробуйте другой

Макрос должен работать один цикл и заканчиваться. При повторном запуске макрос должен перейти к следующему значению в «Списке».

Private Sub CommandButton1_Click()
Dim i As Integer
Dim ws As Worksheet
Dim sh As Worksheet
Set ws = Sheets("Master")
Set sh = Sheets("List")
Application.ScreenUpdating = 0
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    Application.CopyObjectsWithCells = False
    Sheets("Master").Copy After:=sh
    Application.CopyObjectsWithCells = True
    ActiveSheet.Name = sh.Range("A" & i).Value
    ActiveSheet.Range("F3").Value = sh.Range("A" & i).Value
Exit For
Next i
ws.Activate
End Sub

Answer 1

Вам не хватало некоторой информации, чтобы заставить код VBA зацикливаться, если текущее имя (sh.Range("A" & i).value) уже занято на листе.

Вот что я придумала:

Private Sub CommandButton1_Click()
    Dim i As Integer
    Dim ws As Worksheet
    Dim sh As Worksheet

    Dim tmpWS As Worksheet 'will be used to test whether a worksheet already exists

    Set ws = Sheets("Master")
    Set sh = Sheets("List")

    'storing the last row I think is better as well as using explicit
    'definition of the range (sh.Range rather then Range alone)
    Dim lastRow As Integer
    lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 1 To lastRow

        'trying to set a worksheet variable with the new name from the list
        'if the result returns a set variable (variable not returning "Nothing")
        'it means the worksheet exists
        On Error Resume Next '--> will continue even if it encounters an error.  Don't overuse this
        Set tmpWS = ThisWorkbook.Worksheets(sh.Range("a" & i).Value2)
        On Error GoTo 0 '--> will set back default error handling.  From now on, the "Resume Next" is disabled.

        'this is true if worksheet named "sh.Range("A" & i).Value" does not exist
        If (tmpWS Is Nothing) Then

            Excel.Application.CopyObjectsWithCells = False
            Sheets("Master").Copy After:=sh
            ActiveSheet.Name = sh.Range("A" & i).Value
            ActiveSheet.Range("F3").Value = sh.Range("A" & i).Value
            Excel.Application.CopyObjectsWithCells = True
            Exit For

        Else

            'force tmpWS to be set to nothing prior making another run in the loop
            Set tmpWS = Nothing

        End If
    Next i

    ws.Activate

    'important to reactivate the screen updating at the end
    Application.ScreenUpdating = True

End Sub

Полезная справка В заявлении об ошибке