Tuesday, 8 September 2015

How to Create Sheets from Cell Selection with VBA

How to Create Sheets from Cell Selection with VBA

Creating and naming one excel sheet is simple and straight forward but creating about 100, 500 or even more is simple but tedious (VERY TEDIOUS).

Using VBA for excel, it is possible to rapidly create and name as many worksheets as you like. The following example is the use of Excel VBA to achieve this result

The solution below works in three simple steps:
  • Run the code
  • Select your range of cells including the empty cells
  • Click OK to create and name your sheets with the names in the selection you made

Sample Screen Shots

  • Example cell data       Empty cells with green background

  • Run code and you get this asking you to select data range

  • Finally Sheets are created ignoring empty cells

Now The VBA Code

First enable developer options if you haven't already done so.

Press Alt+F11 to open VBA editor
Then Copy and Paste the code below OR download the code file here 
 
Option Explicit  
   Sub cellToSheets()  
     Dim cell As Range  
     Dim i, K, counter As Integer  
     Dim nmActshet, emptyCells, cellNames() As String  
     Dim ws As Worksheet  
      On Error Resume Next  
      nmActshet = ActiveWorkbook.ActiveSheet.Name  
     Set cell = Application.InputBox(prompt:="Select Range", Type:=8) 
     cell.Select  
     K = 0  
     For i = 1 To cell.Count  
       If IsEmpty(cell(i)) = False Then  
        K = K + 1  
       End If  
     Next i  
     ReDim cellNames(K)  
     counter = 1  
     For i = 1 To cell.Count  
       If IsEmpty(cell(i)) = False Then  
         If cell(i).Value <> "" Then  
             cellNames(counter) = cell(i).Value  
             counter = counter + 1  
         End If  
       End If  
     Next i  
     counter = 1  
     For i = 1 To K  
       If verifySimilarSheetNames(cellNames(i)) = False Then  
           Set ws = ActiveWorkbook.Worksheets.Add(After:=Worksheets(ActiveWorkbook.Worksheets.Count))  
           ws.Name = cellNames(counter)  
           counter = counter + 1  
          Else  
             MsgBox "Similar sheet names exist"  
             Exit Sub  
       End If  
     Next i  
     ThisWorkbook.Worksheets(nmActshet).Activate  
   End Sub  
   Function verifySimilarSheetNames(ByVal cellValue As String) As Boolean  
     Dim status As Boolean  
     Dim sheetNames() As String  
     Dim mySheets As Sheets  
     Dim i As Integer  
       status = False  
     Set mySheets = ThisWorkbook.Worksheets  
     ReDim sheetNames(1 To mySheets.Count)  
     For i = 1 To mySheets.Count  
       sheetNames(i) = mySheets(i).Name  
     Next i  
       For i = 1 To UBound(sheetNames)  
         If cellValue = sheetNames(i) Then  
             status = True  
         End If  
       Next i  
     verifySimilarSheetNames = status  
   End Function

Recommended Books






Posted by