使用列表中的名称创建新工作表

Question

我对 VBA 很陌生，我的代码有问题。从单元格 B4 到 B27，我有不同的酒店名称。我的目标是创建新的工作表并用酒店名称命名每个工作表（从列表中向下）。我尝试运行下面的子过程，但出现错误。错误说：

“运行时错误'1004'：应用程序定义的或对象定义的错误”

它指的是我的评论下方的行。关于为什么会发生这种情况以及如何解决这个问题的任何想法？

Sub sheetnamefromlist()

Dim count, i As Integer

count = WorksheetFunction.CountA(Range("B4", Range("B4").End(xlDown)))

i = 4

Do While i <= count

' next line errors
Sheets.Add(after:=Sheets(Sheets.count)).Name = Sheets("LocalList").Cells(i, 2).Text

i = i + 1

Loop

Sheets("LocalList").Activate

End Sub

Answer 1

这是我快速写的东西

几件事

1. 不要像那样找到最后一行。你可能想看看THIS
2. 不要使用.Text 读取单元格的值。你可能想看看What is the difference between .text, .value, and .value2?
3. 在尝试创建工作表之前检查工作表是否存在，否则会出错。

这是你正在尝试的吗？

Option Explicit

Sub sheetnamefromlist()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lRow As Long, i As Long
    Dim NewSheetName As String
    
    '~~> Set this to the relevant worksheet
    '~~> which has the range
    Set ws = ThisWorkbook.Sheets("LocalList")
    
    With ws
        '~~> Find last row
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row
        
        '~~> Loop through the range
        For i = 4 To lRow
            NewSheetName = .Cells(i, 2).Value2
            
            '~~> Check if there is already a worksheet with that name
            If Not SheetExists(NewSheetName) Then
                '~~> Create the worksheet and name it
                With ThisWorkbook
                    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = NewSheetName
                End With
            End If
        Next i
    End With
End Sub

'~~> Function to check if the worksheet exists
Private Function SheetExists(shName As String) As Boolean
    Dim shNew As Worksheet
    
    On Error Resume Next
    Set shNew = ThisWorkbook.Sheets(shName)
    On Error GoTo 0
    
    If Not shNew Is Nothing Then SheetExists = True
End Function

我的假设

1. 所有单元格都有有效值，即可用于工作表名称。如果没有，那么您也必须处理该错误。
2. 工作簿（不是工作表）不受保护

Answer 2

试试，

Sub test()
    Dim vDB As Variant
    Dim rngDB As Range
    Dim Ws As Worksheet, newWS As Worksheet
    Dim i As Integer
    
    Set Ws = Sheets("LocalList")
    With Ws
        Set rngDB = .Range("b4", .Range("b4").End(xlDown))
    End With
    vDB = rngDB 'Bring the contents of the range into a 2D array.
    
    For i = 1 To UBound(vDB, 1)
        Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
        newWS.Name = vDB(i, 1)
    Next i
End Sub

Answer 3

从列表创建工作表

• 以下将仅创建（并计算）具有有效名称的工作表。
• 当工作表已经添加，名称无效时，将被删除（处理不好，但可以。）
• 假定列表是连续的（没有空单元格）。

守则

Option Explicit

Sub SheetNameFromList()

    Const wsName As String = "LocalList"
    Const FirstCell As String = "B4"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim ListCount As Long
    ListCount = WorksheetFunction.CountA(ws.Range(FirstCell, _
                                         ws.Range(FirstCell).End(xlDown)))
    Dim fRow As Long: fRow = ws.Range(FirstCell).Row
    Dim fCol As Long: fCol = ws.Range(FirstCell).Column
    Dim i As Long, wsCount As Long
    
    Do While i < ListCount
        If addSheetAfterLast(wb, ws.Cells(fRow + i, fCol).Value) = True Then
            wsCount = wsCount + 1
        End If
        i = i + 1
    Loop
   
    ws.Activate
    MsgBox "Created " & wsCount & " new worksheet(s).", vbInformation
    
End Sub

Function addSheetAfterLast(WorkbookObject As Workbook, _
                       SheetName As String) _
         As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = WorkbookObject.Worksheets(SheetName)
    If Err.Number = 0 Then Exit Function
    Err.Clear
    WorkbookObject.Sheets.Add After:=WorkbookObject.Sheets(Sheets.count)
    If Err.Number <> 0 Then Exit Function
    Err.Clear
    WorkbookObject.ActiveSheet.Name = SheetName
    If Err.Number <> 0 Then
        Application.DisplayAlerts = False
        WorkbookObject.Sheets(WorkbookObject.Sheets.count).Delete
        Application.DisplayAlerts = False
        Exit Function
    End If
    addSheetAfterLast = True
End Function