Need to exclude "" cells which contains formulas in a Range

[mahira]

Hello,

I have a function that copies a selected sheet called "05" multiple times and rename the sheets as in column A, However there is a function there that returns the value "" when no additional sheets needed.

The current code is counting the empty cells as it uses the End(xlDown). I want it to ignore the empty "" cells which contains formulas.

The code:

Sub CopyTemplate()
Dim wTemplate As Worksheet
Dim wTOC As Worksheet
Dim wCopy As Worksheet
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
Set wTemplate = Worksheets("05")
Set wTOC = Worksheets("Data")
m = wTOC.Range("A1").End(xlDown).Row
For r = 2 To m
wTemplate.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = wTOC.Range("A" & r).Value
Next r
Application.ScreenUpdating = True


End Sub


Thanks a lot in advance!

 

[kevin9999]

Using xlDown is an unreliable way to get the last cell in a range, however, I've left it as is because your task seems relatively simple. Try the following on a copy of your workbook:

Option Explicit
Sub CopyTemplate()
    Dim wTemplate As Worksheet
    Dim r As Long, m As Long, i As Long
    Application.ScreenUpdating = False
    Set wTemplate = Worksheets("05")
    m = Worksheets("Data").Range("A1").End(xlDown).Row
    For r = 2 To m
        If Worksheets("Data").Cells(r, 1) <> "" Then
            For i = 1 To Worksheets.Count
                If Worksheets(i).Name = Worksheets("Data").Range("A" & r).Value Then
                    MsgBox "The worksheet " & Worksheets("Data").Range("A" & r).Value & " already exists"
                    Exit Sub
                End If
            Next i
            wTemplate.Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = Worksheets("Data").Range("A" & r).Value
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

 

[mahira]

Using xlDown is an unreliable way to get the last cell in a range, however, I've left it as is because your task seems relatively simple. Try the following on a copy of your workbook:

Option Explicit
Sub CopyTemplate()
    Dim wTemplate As Worksheet
    Dim r As Long, m As Long, i As Long
    Application.ScreenUpdating = False
    Set wTemplate = Worksheets("05")
    m = Worksheets("Data").Range("A1").End(xlDown).Row
    For r = 2 To m
        If Worksheets("Data").Cells(r, 1) <> "" Then
            For i = 1 To Worksheets.Count
                If Worksheets(i).Name = Worksheets("Data").Range("A" & r).Value Then
                    MsgBox "The worksheet " & Worksheets("Data").Range("A" & r).Value & " already exists"
                    Exit Sub
                End If
            Next i
            wTemplate.Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = Worksheets("Data").Range("A" & r).Value
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

This worked out great! I really appreciate it. However is there a way to skip the existing sheets rather than ending sub? Thank you again!

 

[kevin9999]

Try this:

Option Explicit
Sub CopyTemplate2()
    Dim wTemplate As Worksheet
    Dim r As Long, m As Long, i As Long, exists As Boolean
    Application.ScreenUpdating = False
    Set wTemplate = Worksheets("05")
    m = Worksheets("Data").Range("A1").End(xlDown).Row
    For r = 2 To m
        If Worksheets("Data").Cells(r, 1) <> "" Then
            For i = 1 To Worksheets.Count
                If Worksheets(i).Name = Worksheets("Data").Cells(r, 1) Then exists = True
            Next i
            If Not exists Then
                wTemplate.Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = Worksheets("Data").Range("A" & r).Value
            End If
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

Hi Mahira,

I wasn't happy with the last code I posted, try this version instead:

Option Explicit
Sub CopyTemplate3()
    Dim wTemplate As Worksheet, wTOC As Worksheet
    Set wTemplate = Worksheets("05")
    Set wTOC = Worksheets("Data")
    Dim r As Long, m As Long, i As Long, sh As String, exists As Boolean
    Application.ScreenUpdating = False
    m = wTOC.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To m
        exists = False
        sh = wTOC.Cells(r, 1).Value
        If sh <> "" Then
            For i = 1 To Worksheets.Count
                If Worksheets(i).Name = sh Then exists = True
            Next i
            If Not exists Then
                wTemplate.Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = sh
            End If
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

 

[mahira]

Hi Mahira,

I wasn't happy with the last code I posted, try this version instead:

Option Explicit
Sub CopyTemplate3()
    Dim wTemplate As Worksheet, wTOC As Worksheet
    Set wTemplate = Worksheets("05")
    Set wTOC = Worksheets("Data")
    Dim r As Long, m As Long, i As Long, sh As String, exists As Boolean
    Application.ScreenUpdating = False
    m = wTOC.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To m
        exists = False
        sh = wTOC.Cells(r, 1).Value
        If sh <> "" Then
            For i = 1 To Worksheets.Count
                If Worksheets(i).Name = sh Then exists = True
            Next i
            If Not exists Then
                wTemplate.Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = sh
            End If
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

This code works flawlessly, Thanks again for your time and effort!

 

[kevin9999]

Happy to help & thanks for the feedback