自动重命名选项卡

Question

下面的脚本循环创建选项卡并命名选项卡，然后将选项卡名称放在单元格B3中。它一直运行良好，但现在给出了捕获所有运行时错误1004。在我的脚本底部，它重命名了选项卡。这就是错误发生的地方。它正在创建选项卡，但无法将其重命名。有没有人可以建议用另一种方法来重命名这个脚本中的标签。在Sheets(Name).Select上出现错误。

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

我在所有的选择中迷路了，所以我不确定为什么你的原始代码失败了。我编辑了你的问题，使它更具可读性，但只有我能看到改进，直到我的编辑它同行审查。

我已经删除了你所有的select语句。以“##”开头的评论解释了为什么我做了其他更改。

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

编写健壮的代码是非常重要的。它在任何情况下都不应该失败。例如，应该进行适当的错误处理并声明变量。

我建议你读一下这篇文章。

Topic：To‘Err’是人

链接：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

Answer 3

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