Автоматически переименовать вкладки

Question

Ниже приведен пример сценария для создания вкладок и названия вкладки, после чего он поместит имя вкладки в ячейку B3. Он отлично работает, но теперь дает улову всю ошибку времени выполнения 1004. В нижней части моего сценария она переименовывает вкладку. Здесь происходит ошибка. Он создает вкладки, но не может переименовать его. Может кто-нибудь предложить другой способ переименовать вкладку в этом скрипте. Ошибка указана на листе (имя). Выберите.

Public Sub CreateTabs() 
    Sheets("TABlist").Select 
    ' Determine how many Names are on Data sheet 
    FinalRow = Range("A65000").End(xlUp).Row 
    ' Loop through each Name on the data sheet 
    For x = 1 To FinalRow 
    LastSheet = Sheets.Count 
    Sheets("TABlist").Select 
    Name = Range("A" & x).Value 
    ' Make a copy of FocusAreas and move to end 
    Sheets("TABshell").Copy After:=Sheets(LastSheet) 
    ' rename the sheet and put name in Cell B2 
    Sheets(LastSheet + 1).Name = Name 
    Sheets(Name).Select 
    Range("B3").Value = Name 
    Next x 
End Sub 

Answer 1

Я потерялся среди всех избранных, поэтому не уверен, почему ваш исходный код не удался. Я отредактировал ваш вопрос, чтобы сделать его более читаемым, но только я вижу улучшение до тех пор, пока не изменю его рецензию.

Я удалил все ваши предложения. Комментарии, начинающиеся с ###, объясняют, почему я внес другие изменения.

Option Explicit 
Public Sub CreateTabs() 

    Dim CrntRow As Long    '## I like names I understand 
    Dim FinalRow As Long 
    Dim Name As String 

    ' Determine how many Names are on Data sheet 
    '## Row.Count will work for any version of Excel 
    FinalRow = Sheets("TABlist").Cells(Rows.Count, "A").End(xlUp).Row 
    ' Loop through each Name on the data sheet 
    For CrntRow = 1 To FinalRow 
    Name = Sheets("TABlist").Range("A" & CrntRow).Value 
    ' Make a copy of FocusAreas and move to end 
    Sheets("TABshell").Copy After:=Sheets(Worksheets.Count) 
    ' rename the sheet and put name in Cell B2 
    '## The copy will be the active sheet 
    With ActiveSheet 
     .Name = Name 
     .Range("B3").Value = Name 
    End With 
    Next CrntRow 

End Sub 

Answer 2

Каждое имя рабочего листа в книге Excel должно быть уникальным.

В качестве быстрого исправления, чтобы узнать, какое имя вызывает ошибку, попробуйте использовать этот код, а затем проверьте имена листов в списке.

Public Sub CreateTabs() 

On Error Resume Next 

    Sheets("TABlist").Select 
    ' Determine how many Names are on Data sheet 
    FinalRow = Range("A65000").End(xlUp).Row 
    ' Loop through each Name on the data sheet 
    For x = 1 To FinalRow 
    LastSheet = Sheets.Count 
    Sheets("TABlist").Select 
    Name = Range("A" & x).Value 
    ' Make a copy of FocusAreas and move to end 
    Sheets("TABshell").Copy After:=Sheets(LastSheet) 
    ' rename the sheet and put name in Cell B2 
    Sheets(LastSheet + 1).Name = Name 
    Sheets(Name).Select 
    Range("B3").Value = Name 
    Next x 

On Error GoTo 0 

End Sub 

Answer 3

Очень важно написать надежный код. Это не должно прерываться ни в одном сценарии. Например, необходимо выполнить соответствующую обработку ошибок и объявить переменные.

Я бы рекомендовал прочитать это.

Тема: К «Err» является Human

Ссылка: http://www.siddharthrout.com/2011/08/01/to-err-is-human/

Теперь вернемся к коду. Я внесла поправки в код. Попробуй это. Я также прокомментировал код, поэтому вам не должно быть никаких трудностей в его понимании :) Тем не менее, если вы это сделаете, просто дайте крик.

Код

Option Explicit 

Public Sub CreateTabs() 
    Dim ws As Worksheet 
    Dim FinalRow As Long, x As Long, LastSheet As Long 
    Dim name As String 

    On Error GoTo Whoa 

    Application.ScreenUpdating = False 

    Set ws = Sheets("TABlist") 

    FinalRow = ws.Range("A" & Rows.Count).End(xlUp).Row 

    For x = 1 To FinalRow 
     LastSheet = Sheets.Count 

     '~~> Get the name for the new sheet 
     name = ws.Range("A" & x).Value 

     '~~> Check if you already have a sheet with that name or not 
     If Not SheetExists(name) Then 
      Sheets("TABshell").Copy After:=Sheets(LastSheet) 
      ActiveSheet.name = name 
      Range("B3").Value = name 
     End If 
    Next x 

LetsContinue: 
    Application.ScreenUpdating = True 
    Exit Sub 
Whoa: 
    MsgBox Err.Description 
    Resume LetsContinue 
End Sub 

'~~> Function to check if sheet exists 
Function SheetExists(wst As String) As Boolean 
    Dim oSheet As Worksheet 
    On Error Resume Next 
    Set oSheet = Sheets(wst) 
    On Error GoTo 0 

    If Not oSheet Is Nothing Then SheetExists = True 
End Function