0
votes

I have a macro to create a new worksheet and rename that sheet with hyperlink based on the value of cell in the "Master" sheet range("A5").

It will stop at a blank cell. What should I add to skip the blank cell and continue?

Function CheckSheetExists(ByVal name As String)
' checks if a worksheet already exists

Dim retVal As Boolean

retVal = False

For s = 1 To Sheets.Count
    If Sheets(s).name = name Then
        retVal = True
        Exit For
    End If
Next s

CheckSheetExists = retVal

End Function

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange

    On Error Resume Next

    If CheckSheetExists(MyCell.Value) = False Then

        Sheets("Template").Copy After:=Sheets(Sheets.Count)

        With Sheets(Sheets.Count)
            .name = MyCell.Value
            .Cells(3, 1) = MyCell.Value

        End With
    End If

On Error GoTo 0

MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"

Next MyCell
End Sub
3

3 Answers

0
votes

Your problem is likely this assignment:

Set MyRange = Range(MyRange, MyRange.End(xlDown))

The End(xlDown) method will stop on a blank cell (generally).

See this other answer for more reliable ways to find the "last" cell in a given range.

You may also want to move your MyCell.Hyperlinks.Add statement within the If CheckSheetExists block, and you'll need to add logic to skip empty cells (if there are empty cells within the MyRange.

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

With Sheets("Master")
Set MyRange = .Range("A5")
Set MyRange = .Range(MyRange, .Range("A" & .Rows.Count).End(xlUp))

For Each MyCell In MyRange

    On Error Resume Next

    If CheckSheetExists(MyCell.Value) = False And MyCell.Value <> vbNullString Then

        Sheets("Template").Copy After:=Sheets(Sheets.Count)

        With Sheets(Sheets.Count)
            .name = MyCell.Value
            .Cells(3, 1) = MyCell.Value

        End With
        MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
    End If

On Error GoTo 0

Next MyCell
End Sub
0
votes

How about:

For Each MyCell In MyRange
    If MyCell.Value <> "" Then
        On Error Resume Next
            If CheckSheetExists(MyCell.Value) = False Then
                Sheets("Template").Copy After:=Sheets(Sheets.Count)
                With Sheets(Sheets.Count)
                    .Name = MyCell.Value
                    .Cells(3, 1) = MyCell.Value
                End With
            End If
        On Error GoTo 0
        MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
    End If
Next MyCell
0
votes

You need to add check of blank cell in you loop, for example: I added check in the second row (and end if just before end of loop) - it checks length of text in the cell:

For Each MyCell In MyRange
IF(LEN(MYCELL.VALUE)>0) THEN
    On Error Resume Next

    If CheckSheetExists(MyCell.Value) = False Then

        Sheets("Template").Copy After:=Sheets(Sheets.Count)

        With Sheets(Sheets.Count)
            .name = MyCell.Value
            .Cells(3, 1) = MyCell.Value

        End With
    End If

On Error GoTo 0

MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
END IF
Next MyCell

EDIT: I would change the function checking if WS exists:

Function CheckSheetExists(ByVal name As String) as boolean
dim WS as worksheet

on error resume next
set ws = Worksheet(name)
on error goto 0

if(ws is nothing) then
CheckSheetExists = false
else
CheckSheetExists = true
end if

set ws=nothing

End Function