How to copy a worksheet and rename it after a selected cell?

May 17, 2018 at 14:32:46
Specs: Windows 10
Hey,
I have a blank worksheet ("blank") I want to copy based on new data I enter into a list ("ALL PROJECT")Starting with Cell A4. The thing is I want to add to this list periodically and run the Macro again adding only sheets for the new entries. I am okay if I have to select the first cell in the new group of entries.

Thank you
Chris


See More: How to copy a worksheet and rename it after a selected cell?

Report •

#1
May 18, 2018 at 09:01:09
The following code will scan Column A (starting in A4) looking for entries that do not match any of the existing sheet names. If a sheet does not exist for a given value, the code will copy the "blank" worksheet, place it as the last sheet in the workbook and rename it to match that value.

The first thing that the code does is check for any issues that would cause an error if you tried to do this manually:

1 - Duplicate values that would cause a "Duplicate sheet name" error
2 - Values that would result in a sheet name that is more than 31 characters
3 - Values that contain any illegal sheet name characters: / \ [ ] * ? :
4 - A value of "History" which is a reserved word within Excel and can't be used as a sheet name

If any of those conditions are found during the initial scan, the code will not create any new sheets until you correct the issue(s). In other words, it's not going to skip the problem values and create sheets for the good ones. The search for problems anywhere in the list is done before any new sheets are created. That is done so that code doesn't have to keep track of good values vs. bad. The code wants a nice, clean list to work with.

Additional note: The code is not going to delete/change any sheet names if you delete/change a value in Column A. It's not actually matching sheet names to Column A values, it's just looking for Column A values that don't have a matching sheet name. I hope that that subtle difference makes sense.

Let me know if anything strange pops up as you test the code. There may be issues with the values that you plan to use that I can't foresee.

Sub AddNewSheets()
Dim newSheets()
Dim illChar()
Dim lastShtName As Long
Dim shtName As Long
Dim newName As Long
Dim shtNum As Long
Dim addSheet As Long
Dim illChk As Long
Dim exists As Boolean

'Determine Last Cell in Column A With Data
  With Sheets("blank")

   lastShtName = .Range("A" & Rows.Count).End(xlUp).Row

'Set up Array of Illegal Sheet Name Characters

  illChar = Array("/", "\", "[", "]", "*", "?", ":")
  
'Check For Duplicate Sheet Names or Illegal Sheet Names

   For shtName = 4 To lastShtName
   
'Duplicates?
    If WorksheetFunction.CountIf(.Range("A4:A" & lastShtName), .Range("A" & shtName)) > 1 Then
               MsgBox .Range("A" & shtName).Value & " exists more than once." & _
                      vbCrLf & vbCrLf & _
                      "Please Correct and Rerun Macro"
               Exit Sub
    End If
    
'Too long?
    If Len(.Range("A" & shtName)) > 31 Then
               MsgBox "Cell " & .Range("A" & shtName).Address & " Contains a Sheet " & _
                      "Name that is longer than 31 Characters." & _
                      vbCrLf & vbCrLf & _
                      "Please Correct and Rerun Macro"
               Exit Sub
     End If
    
'Reserved word - History?
    If .Range("A" & shtName) = "History" Then
               MsgBox "Cell " & .Range("A" & shtName).Address & " Contains 'History' " & _
                      "which is a reserved word" & _
                      vbCrLf & vbCrLf & _
                      "Please Correct and Rerun Macro"
               Exit Sub
     End If
     
'Illegal Characters?
    For illChk = 0 To UBound(illChar())
        If InStr(.Range("A" & shtName), illChar(illChk)) > 0 Then
               MsgBox .Range("A" & shtName).Address & " contains an illegal character." & _
                      vbCrLf & vbCrLf & _
                      "/   \   [   ]   *   ?   :" & _
                      vbCrLf & vbCrLf & _
                      "Please Correct and Rerun Macro"
               Exit Sub
        End If
     Next
     
   Next

'Check If Sheet Exists, If Not, Add New Sheet Name To Array

ReDim newSheets(lastShtName)

     For shtName = 4 To lastShtName
     
        exists = False
        
          For shtNum = 1 To Worksheets.Count
             If Worksheets(shtNum).Name = CStr(.Range("A" & shtName)) Then
                exists = True
                Exit For
             End If
          Next shtNum
        
          If Not exists Then
               newSheets(newName) = .Range("A" & shtName)
               newName = newName + 1
          End If

      Next
      
'Loop Through Array, Copying And Naming New Sheets

      For addSheet = 0 To UBound(newSheets)
      
         If newSheets(addSheet) <> "" Then
            Sheets("blank").Copy after:=Sheets(Sheets.Count)
            ActiveSheet.Name = newSheets(addSheet)
         End If
         
      Next

  End With
  
Sheets("blank").Activate

End Sub


How To Post Data or Code ---> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03


Report •

#2
May 18, 2018 at 11:48:11
DerbyDad03,
Thank you so much. I am blown away at how quick you responded to this problem. I have copied it and tried it. I did need to change the line

With Sheets("blank")
to
With Sheets("ALL PROJECT")

This caused an error because I have a formula in this collumn that returns a blank if nothing is in the next column.
I am trying to name the sheets based on dates, which I realize don't work because of the "/" in the date, even when I fromat it to "17-May-18". So I have created a second collumn that adds a hyphen before (ie "-17-May-18").
I am thinking that even though I have the formula showing a blank cell, there is still a formula there that causes a duplicate error.

Thanks again, I am beyond impressed.


Report •

#3
May 18, 2018 at 12:50:06
EDIT: Read the text in this post, but use the code in Response #4. I added code to deal with the blank cells returned by the formula.


I tried to make the code as generic as possible. If you are only going to use it to create sheets based on dates, then you can eliminate 2 of the 3 "checking for possible issues" code and just check for duplicates.

If you don't check for the "/", you won't get that error. Then we can let the code convert both the cell and the sheet name to a text string, although only the sheet name will actually get formatted that way. A date like 5/18/2018 will be converted internally whatever format you choose. e.g. May 18, 2018 or May-18-2018. You won't need that helper column.

Format(.Range("A" & shtName), "mmm dd, yyyy")

or

Format(.Range("A" & shtName), "dd-mmm-yyyy")

Try this version. If this doesn't work, I'll need to see some examples of the data that you are using to create the sheets. I'm kind of flying blind here.


Sub AddNewDateSheets()
Dim newSheets()
Dim lastShtName As Long
Dim shtName As Long
Dim newName As Long
Dim shtNum As Long
Dim addSheet As Long
Dim exists As Boolean

'Determine Last Cell in Column A With Data
  With Sheets("ALL PROJECT")

   lastShtName = .Range("A" & Rows.Count).End(xlUp).Row

''Check For Duplicate Sheet Names or Illegal Sheet Names

   For shtName = 4 To lastShtName

'Duplicates?
    If WorksheetFunction.CountIf(.Range("A4:A" & lastShtName), .Range("A" & shtName)) > 1 Then
               MsgBox .Range("A" & shtName).Value & " exists more than once." & _
                      vbCrLf & vbCrLf & _
                      "Please Correct and Rerun Macro"
               Exit Sub
    End If

   Next

'Check If Sheet Exists, If Not, Add New Sheet Name To Array

ReDim newSheets(lastShtName)

     For shtName = 4 To lastShtName
     
        exists = False
        
          For shtNum = 1 To Worksheets.Count
             If Worksheets(shtNum).Name = Format(.Range("A" & shtName), "mmm dd, yyyy") Then
                exists = True
                Exit For
             End If
          Next shtNum
        
          If Not exists Then
               newSheets(newName) = Format(.Range("A" & shtName), "mmm dd, yyyy")
               newName = newName + 1
          End If

      Next
      
'Loop Through Array, Copying And Naming New Sheets

      For addSheet = 0 To UBound(newSheets)
      
         If newSheets(addSheet) <> "" Then
            Sheets("blank").Copy after:=Sheets(Sheets.Count)
            ActiveSheet.Name = newSheets(addSheet)
         End If
         
      Next

  End With
  
Sheets("ALL PROJECT").Activate

End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03


Report •

Related Solutions

#4
May 18, 2018 at 16:52:04
I forgot to address this comment:

"This caused an error because I have a formula in this collumn that returns a blank if nothing is in the next column."

This version should fix that:

Sub AddNewDateSheets()
Dim newSheets()
Dim lastShtName As Long
Dim shtName As Long
Dim newName As Long
Dim shtNum As Long
Dim addSheet As Long
Dim exists As Boolean

'Determine Last Cell in Column A With Data
  With Sheets("ALL PROJECT")

   lastShtName = .Range("A" & Rows.Count).End(xlUp).Row

''Check For Duplicate Sheet Names or Illegal Sheet Names

   For shtName = 4 To lastShtName
    If .Range("A" & shtName) <> "" Then
'Duplicates?
      If WorksheetFunction.CountIf(.Range("A4:A" & lastShtName), .Range("A" & shtName)) > 1 Then
               MsgBox .Range("A" & shtName).Value & " exists more than once." & _
                             vbCrLf & vbCrLf & _
                             "Please Correct and Rerun Macro"
               Exit Sub
      End If
    End If
   Next

'Check If Sheet Exists, If Not, Add New Sheet Name To Array

ReDim newSheets(lastShtName)

     For shtName = 4 To lastShtName
     
        exists = False
        
          For shtNum = 1 To Worksheets.Count
             If Worksheets(shtNum).Name = Format(.Range("A" & shtName), "mmm dd, yyyy") Then
                exists = True
                Exit For
             End If
          Next shtNum
        
          If Not exists Then
               newSheets(newName) = Format(.Range("A" & shtName), "mmm dd, yyyy")
               newName = newName + 1
          End If

      Next
      
'Loop Through Array, Copying And Naming New Sheets

      For addSheet = 0 To UBound(newSheets)
      
         If newSheets(addSheet) <> "" Then
            Sheets("blank").Copy after:=Sheets(Sheets.Count)
            ActiveSheet.Name = newSheets(addSheet)
         End If
         
      Next

  End With
  
Sheets("ALL PROJECT").Activate

End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#5
May 21, 2018 at 10:11:13
Thank you so much.This was exactly what I needed. This will be a code I can use on many project in the future.


Report •

Ask Question