创建工作表并使用列表/表格中的值命名它们[重复]

Question

我正在尝试在工作簿中创建多个工作表，并根据特定表中的内容命名它们。我这样做是因为列表可以是动态的，并且可能需要根据要求创建更多/更少的工作表。

Sub CreateSheetsFromList()

Dim NewSheet As Worksheet
Dim x As Integer
Dim tbl As ListObject
Dim cell As Range


  Application.ScreenUpdating = False

  Set tbl = Worksheets("Sheet1").ListObjects("Table1")


  For Each cell In tbl.DataBodyRange.Cells
    If SheetExists(cell.Value) = False And cell.Value <> "" Then
      Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
      NewSheet.Name = cell.Value
    End If
  Next cell

  Application.ScreenUpdating = True
  
End Sub

Function SheetExists(SheetName As String) As Boolean

Dim sht As Worksheet


  On Error Resume Next
    Set sht = ActiveWorkbook.Worksheets("Sheet1")
  On Error GoTo 0


  If Not sht Is Nothing Then SheetExists = True

  Set sht = Nothing

End Function

无法获得任何结果。请告诉我是否有办法以优化的方式做到这一点

Answer 1

您必须使用传递的变量来检查 - 不是固定值（“Sheet1”）：

Function SheetExists(SheetName As String) As Boolean

  Dim sht As Worksheet

  On Error Resume Next
   'Use the passed SheetName to test for
    Set sht = ActiveWorkbook.Worksheets(SheetName)
  On Error GoTo 0

  If Not sht Is Nothing Then SheetExists = True

End Function

Answer 2

从 Excel 表格添加工作表 (

ListObject

)

用法

Sub AddSheetsFromListObjectTEST()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ash As Object: Set ash = wb.ActiveSheet
    
    Application.ScreenUpdating = False
    
    AddSheetsFromListObject wb, "Sheet1", "Table1", 1
    ash.Activate
     
    Application.ScreenUpdating = True

End Sub

方法

Sub AddSheetsFromListObject( _
        ByVal wb As Workbook, _
        ByVal WorksheetID As Variant, _
        ByVal ListObjectID As Variant, _
        ByVal ListColumnID As Variant)
    Const PROC_TITLE As String = "Add Sheets From ListObject"
    Dim WasSheetAdded As Boolean
    On Error GoTo ClearError
    
    Dim sws As Worksheet: Set sws = wb.Sheets(WorksheetID)
    Dim slo As ListObject: Set slo = sws.ListObjects(ListObjectID)
    Dim slc As ListColumn: Set slc = slo.ListColumns(ListColumnID)
    Dim srg As Range: Set srg = slc.DataBodyRange
    
    Dim dsh As Object, sCell As Range, sValue As Variant, dName As String
    Dim WasSheetNotRenamed As Boolean
    
    For Each sCell In srg.Cells
        sValue = sCell.Value
        If Not IsError(sValue) Then
            If Len(sValue) > 0 And Len(sValue) < 32 Then dName = CStr(sValue)
        End If
        If Len(dName) > 0 Then
            On Error Resume Next
                Set dsh = wb.Sheets(dName) ' attempt to reference existing sheet
            On Error GoTo ClearError
            If dsh Is Nothing Then ' sheet doesn't exist
                If WasSheetAdded Then
                    Set dsh = wb.Sheets(wb.Sheets.Count) ' reference last sheet
                Else
                    Set dsh = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    WasSheetAdded = True
                End If
                On Error GoTo RenameError
                    dsh.Name = dName ' attempt to rename the new sheet
                On Error GoTo ClearError
                If WasSheetNotRenamed Then ' sheet was not renamed
                    WasSheetNotRenamed = False ' reset for the next iteration
                Else ' sheet was renamed i.e. SUCCESS
                    WasSheetAdded = False ' reset for the next iteration
                End If
            'Else ' sheet exists i.e. SUCCESS; do nothing
            End If
            Set dsh = Nothing ' reset whether it existed or not
            dName = vbNullString ' reset for the next iteration
         'Else ' error, blank or too long i.e. dName = ""; do nothing
         End If
    Next sCell
            
ProcExit:
    On Error Resume Next
        If WasSheetAdded Then '
            Application.DisplayAlerts = False
                wb.Sheets(wb.Sheets.Count).Delete
            Application.DisplayAlerts = True
        End If
    On Error GoTo 0
    Exit Sub
RenameError:
    WasSheetNotRenamed = True
    Resume Next
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub