Create sheets with the value of a cell until there are no more values

Question

I am trying to make this code work in a "special" way, I need it to create sheets with the value of a cell until there are no more values.

I tried to do it with the following line, but it doesn't work:

'For Each Rango In wSh.Range("D1").End(xlUp).Row

This code works by manually entering the range.

Sub AddSheets()
    Dim Rango As Excel.Range
    Dim Hoja As Excel.Worksheet
    Dim Libro As Excel.Workbook
    Set Hoja = Sheets("Hoja 2")
    Set Libro = ActiveWorkbook
    Application.ScreenUpdating = False
    'For Each Rango In Hoja.Range("D1").End(xlUp).Row
    For Each Rango In Hoja.Range("D1:D5")
        With Libro
            .Sheets.Add after:=.Sheets(.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = Rango.Value
            If Err.Number = 1004 Then
                Debug.Print Rango.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next Rango
    Application.ScreenUpdating = True
End Sub

Can you tell me how to make the code do what I need it to do?

Answer 1

I would do this slightly different.

LOGIC

1. Find the last row in column D as shown HERE
2. Loop through the range and then check if the cell in D has some value. i.e the new worksheet name cannot be blank.
3. Loop through the range and then check if the value from the D cell can be used to name a sheet. We check for invalid characters and character limit using IsValidSheetName()
4. The next check we do is to check if there is already a sheet with that name. For this, I am using DoesSheetExist()
5. Only if the above checks pass, do we add a sheet and rename it. In your current scenario, you will end up with lot of worksheets if there are errors.

CODE

Is this what you are trying? I have commented the code so you should not have a problem understanding it. But if you do, then, simply ask.

Option Explicit

Sub AddSheets()
    Dim Hoja As Worksheet
    Dim Libro As Workbook
    Dim LRow As Long
    Dim i As Long
    Dim NewSheetName As String
    
    Set Libro = ThisWorkbook
    Set Hoja = Libro.Sheets("Hoja 2")
    
    Application.ScreenUpdating = False
    
    With Hoja
        '~~> Find last row in column D
        LRow = .Range("D" & .Rows.Count).End(xlUp).Row
        
        For i = 1 To LRow
            NewSheetName = .Range("D" & i).Value2
            
            '~~> Check if the worksheet name is not blank
            If Len(Trim(NewSheetName)) = 0 Then
                Debug.Print "The worksheet name cannot be blank"
            '~~> Check if the sheet name is valid
            ElseIf IsValidSheetName(NewSheetName) = False Then
                Debug.Print "The sheet name " & NewSheetName & _
                " cannot have length more than 31 " & _
                "characters. Neither it can contain the characters /,\,[,],*,?,:"
            '~~> Check if there is no other sheet with that name
            ElseIf DoesSheetExist(NewSheetName) Then
                Debug.Print "There is already a sheet with the name." & NewSheetName
            Else
                Libro.Sheets.Add after:=Libro.Sheets(Libro.Sheets.Count)
                ActiveSheet.Name = NewSheetName
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

'~~> Function to check if the sheet name is valid
Private Function IsValidSheetName(userinput As Variant) As Boolean
    Dim IllegalChars As Variant
    Dim i As Long
    
    IllegalChars = Array("/", "\", "[", "]", "*", "?", ":")
    
    If Len(userinput) > 31 Then Exit Function
    
    For i = LBound(IllegalChars) To UBound(IllegalChars)
        If InStr(userinput, (IllegalChars(i))) > 0 Then Exit Function
    Next i

    IsValidSheetName = True
End Function

'~~> Function to check if worksheet exists
Private Function DoesSheetExist(userinput As Variant) As Boolean
    Dim wsh As Worksheet
    
    On Error Resume Next
    Set wsh = ThisWorkbook.Sheets(userinput)
    On Error GoTo 0
    
    If Not wsh Is Nothing Then DoesSheetExist = True
End Function

IN ACTION

Answer 2

One way:

For Each Rango In wSh.Range("D1:D" & wSh.Cells(wSh.rows.count, "D").end(xlup).row).Cells

Answer 3

Thanks to all for the contributions, finally the code is functional as follows:

Sub Creacion_hojas()

Dim Rango As Excel.Range
Dim Hoja As Excel.Worksheet
Dim Libro As Excel.Workbook
Set Hoja = ThisWorkbook.Worksheets("Hoja 2")
Set Libro = ActiveWorkbook
Dim lCopyLastRow As Long

'1. Find last used row in the copy range based on data in column A
  lCopyLastRow = Cells(Hoja.Rows.Count, "D").End(xlUp).Row

Application.ScreenUpdating = False
For Each Rango In Hoja.Range("D1:D" & lCopyLastRow)
With Libro
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = Rango.Value
If Err.Number = 1004 Then
Debug.Print Rango.Value & "Actualmente la hoja esta creada"
End If
On Error GoTo 0
End With
Next Rango
Application.ScreenUpdating = True
End Sub