I am trying to create multiple worksheet in a workbook and name them based on a contents in a particular table. I am doing this as the list can be dynamic and might need to create more/less sheets depending on the requirement.

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

Unable to get any kind of results. Please let me know if there is a way to do this in an optimized manner

CodePudding user response：

You have to use the passed variable to check - not a fixed value ("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

CodePudding user response：

Code

Function cleanString(str As Variant) As String
    'https://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
    'kudos to stackoverflow member @ashleedawg 6 Nov '18 (original code below-no amendments)
    Dim ch, bytes() As Byte: bytes = str
    For Each ch In bytes
        If Chr(ch) Like "[A-Z.a-z 0-9]" Then cleanString = cleanString & Chr(ch)
    Next ch
End Function

Function DoesSheetExists(sh As Variant) As Boolean 'Siddharth Rout 2019
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sh)
    On Error GoTo 0

    If Not ws Is Nothing Then DoesSheetExists = True
End Function

Sub CreateSheets()
'adapted fromhttps://www.get-digital-help.com/quicky-create-new-sheets-vba/
'kudos to Oscar Cronquist Article last updated on October 16, 2022


'Dimension variables and declare data types
Dim rng, cell As Range
Dim msg As String

'Enable error handling
On Error GoTo Errorhandling
 
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)
 
Start = ActiveSheet.Name

'Iterate through cells in selected cell range
For Each cell In rng: Do
 
    c1 = CStr(cell.Value)
    c2 = cleanString(c1)
    
    c1_L = Len(c1)
    c2_L = Len(c2)
    
    do_more = False
    
    If DoesSheetExists(c2) Then
        txt = "omitted  - sheet name already exists"
        msg = msg   ", "   cell.Address   ", "   txt   "*"
        Exit Do
    Else
    
        Select Case c2_L
            Case 0
                txt = "omitted - blank after special chars removed"
                msg = msg   ", "   cell.Address   ", "   txt   "*"
                Exit Do
               
            Case Is > 31
                txt = "truncated to 31 chars after removing specials"
                c2 = Left(c2, 31)
                do_more = True
    
            Case Is <> c1_L
                txt = "special chars removed"
                do_more = True
                
    
        End Select
    
                
    End If
    
    If do_more Then
        msg = msg   ", "   cell.Address   ", "   txt   "*"
    End If
    
    Sheets.Add(After:=ActiveSheet).Name = c2
    
            
 
'Continue with next cell in cell range
Loop While False: Next cell 'in conjunciton with For loop & Exit Do: Do https://stackoverflow.com/questions/8680640/vba-how-to-conditionally-skip-a-for-loop-iteration @Unhandled Exception 2018

'If Left(msg, 1) = "," Then
'    msg = Right(msg, Len(msg) - 1)
'End If
'
'If Right(msg, 1) = "," Then
'    msg = Left(msg, Len(msg) - 1)
'End If
'
result = Split(msg, "*")

msg = ""

For Each res In result:
    If Left(res, 2) = ", " Then
        res = Right(res, Len(res) - 2)
    End If
    If Right(res, 1) = "," Then
        res = Left(res, Len(res) - 1)
    End If
    
    msg = msg   res   vbNewLine
Next



    
Sheets(Start).Activate

MsgBox (msg)


'Go here if an error occurs
Errorhandling:
 
'Stop macro
End Sub