Create Sheets From Cell Values

2 minute read

This is one of my favourites and I use it all the time. Type a bunch of sheet names in a list of cells, select those cells then run this macro.

  • Users will be prompted to select a range of cells to create sheet names
  • Error checks that the sheet name doesn’t already exist - highlights those cells Yellow
  • Error checks that the cell doesn’t contain illegal sheet name characters \ / * [ ] : ?
  • Error checks that the cell value doesn’t have more than the 31 character sheet name limit
  • Highlights cells red containing illegal characters or exceeding 31 characters
  • Skips cells that are blank
  • Checks if the Workbook Protection is on, notifies user and exits sub
' ======================================================================================================
'## Creates sheet names in the active workbook from selected cell value
'   - Users will be prompted to select a range of cells to create sheet names
'   - Error checks that the sheet name doesn't already exist - highlights those cells Yellow
'   - Error checks that the cell doesn't contain illegal sheet name characters \ / * [ ]  : ?
'   - Error checks that the cell value doesn't have more than the 31 character sheet name limit
'   - Highlights cells red containing illegal characters or exceeding 31 characters
'   - Skips cells that are blank
'   - Checks if the Workbook Protection is on, notifies user and exits sub
'=======================================================================================================
Sub AddSheetFromString()

  ' Vars
    Dim strRng As String
    Dim rngCell As Range
    Dim rngSelection As Range
    Dim blnError As Boolean
    Dim strPrompt As String

    ' Test a range selected
    If TypeName(Selection) <> "Range" Then Exit Sub

    ' Pass the selected cells address to a string
    strRng = ActiveWindow.RangeSelection.Address

    ' Briefly turn off error checking
    On Error Resume Next

    ' Pick the range using an inputbox, the initial range is the currently selected cells
    strPrompt = "Select cells, the values will be the new sheets names" & vbDoubleLine & _
                "Any duplicates will be highlighted yellow, errors highlighted red"
    Set rngSelection = Application.InputBox(strPrompt, "Create Sheets", strRng, Type:=8)

    ' Test if clicked cancel
    If rngSelection Is Nothing Then Exit Sub

    ' Turn on error checking
    On Error GoTo 0

    ' Optimise, turn off Screen Updating
    Application.ScreenUpdating = False

    ' Loop through each cell in the selected range
    For Each rngCell In rngSelection

        ' Test for blank cells, skip these
        If rngCell.Value = "" Then GoTo NextCell

        ' Test if any sheets are named the same as any of the cell values
        '   if so then paint that cell yellow and go to the next cell
        For Each Worksheet In ActiveWorkbook.Worksheets
            If rngCell = Worksheet.Name Then
                rngCell.Interior.Color = vbYellow
                GoTo NextCell
            End If
        Next Worksheet

        ' Test no invalid characters in folder for sheet name and that the
        '   character counr does not exceed the 31 sheet name character limit
        '   Paint the cell red and go to the next cell in the selected range
        If InStr(rngCell, "\") > 0 Or InStr(rngCell, "/") > 0 Or InStr(rngCell, "*") > 0 Or _
            InStr(rngCell, "[") > 0 Or InStr(rngCell, "]") > 0 Or InStr(rngCell, ":") > 0 Or _
            InStr(rngCell, "?") > 0 Or _
            Len(rngCell) > 31 Then
            rngCell.Interior.Color = vbRed
            GoTo NextCell
        End If

        ' Add a worksheet
        ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)

        ' Cell value is a valid sheet name, new sheet is the cell value
        Sheets(Sheets.Count).Name = rngCell.Value
NextCell:
    Next rngCell

    ' Optimise, turn on Screen Updating
    Application.ScreenUpdating = True

End Sub

Tags:

Categories:

Updated: