Create Several Worksheets from One - VBA

This code will ADD new sheets to your Workbook based on the values in Column A of the "Handheld Info" worksheet:

Sub EE_AddSheetsToWrkBk()
Dim srcWorkSheet As Worksheet, shtName As String
Set srcWorkSheet = Sheets("HandHeld Info")    ' You can change the sheet here
For nm = 1 To srcWorkSheet.UsedRange.Rows.Count
    shtName = Cells(nm, 1).Value     ' NAMES are all in Column A only
    Sheets.Add
    ActiveSheet.Name = shtName
    srcWorkSheet.Select
Next nm
End Sub

Cook09..

You can try the following code..This will break your entire sheet of Handheld info into various sheet tabs and will copy the data as well for that particular value...

In additional your names were too big..However you can rename sheet only till 31 characters so whenever your sheet tab name was bigger then 31 i have trimmed it down to 31 characters..

Now for other part of the question which is creating sheet tabs for barcodes..i keep it a separate question as i need few clarity from you on that before i can make the code for the same..

Option Explicit

Sub createsheettabs()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Dim rng As Range, cell As Range
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim ws3 As Worksheet, r As Range
    Dim lrow As Long, lr As Long

    Set ws1 = Sheets("Handheld Info")
    Set ws2 = Sheets("Handheld Barcodes")


    'clearing old ws before creating news ones as will run from scratch
    For Each ws In ActiveWorkbook.Worksheets

        If ws.Name <> ws1.Name And ws.Name <> ws2.Name Then ws.Delete
    Next ws

    lrow = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws1.Range("A2:A" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
        cell.Value = Trim(cell.Value)
            Set r = ws1.Range("A2:A" & cell.Row)
            If Application.WorksheetFunction.CountIf(r, cell.Value) = 1 Then
                Sheets.Add AFTER:=Sheets(Sheets.Count)
                If Len(cell.Value) > 31 Then
                    ActiveSheet.Name = Left(cell.Value, 31)
                Else
                    ActiveSheet.Name = cell.Value
                End If

                Set ws3 = ActiveSheet

                ws1.Range("A1:G1").Copy ws3.Range("A1")
            Else
                If Len(cell.Value) > 31 Then
                    Set ws3 = Sheets(Left(cell.Value, 31))
                Else
                    Set ws3 = Sheets(cell.Value)
                End If

            End If

            lr = ws3.Cells(Cells.Rows.Count, "a").End(xlUp).Row + 1

            ws1.Range("A" & cell.Row & ":G" & cell.Row).Copy ws3.Range("A" & lr)
            ws3.Cells.EntireColumn.AutoFit
            Set ws3 = Nothing
        End If
    Next cell

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


End Sub

Select allOpen in new window

Saurabh...

Great catch on the LENGTH, Saurabh! Here is my adjusted code to ADD Worksheets: (You can ignore my first post.)

Sub EE_AddSheetsToWrkBk()
Dim srcWorkSheet As Worksheet, shtName1 As String, shtName2 As String
Set srcWorkSheet = Sheets("HandHeld Info")  ' You can change the sheet here
On Error Resume Next
For nm = 1 To srcWorkSheet.UsedRange.Rows.Count
    If Trim(Cells(nm, 1).Value) <> "" Then
        If Len(Cells(nm, 1).Value) > 31 Then
            shtName1 = Left(Trim(Cells(nm, 1).Value), 31)
        Else
            shtName1 = Trim(Cells(nm, 1).Value)      ' NAMES are all in Column A only
        End If
        If Len(Cells(nm + 1, 1).Value) > 31 Then
            shtName2 = Left(Trim(Cells(nm + 1, 1).Value), 31)
        Else
            shtName2 = Trim(Cells(nm + 1, 1).Value)    ' Compares NAMES in Column A only
        End If
        If shtName1 <> shtName2 Then
            Sheets.Add
            ActiveSheet.Name = shtName1
        End If
        srcWorkSheet.Select
    End If
Next nm
On Error GoTo 0
End Sub

Was just checking to see if there was any posting and am glad there was.  Will try these out on Monday.  Thanks...

Cook09

Saurabh's code worked as envisioned.  But with the large number of tabs (worksheets) is there a way to easily navigate to the city (Table of Contents, or hyperlinks, etc.)?

Thanks,
Cook09

In case of large sheet tabs..where it shows the sheet tabs..you have extreme right arrow with Pipe sign in front of it..Just press that and it will show the first sheet which is basically your raw data sheet and you can select that...

Or in the end you can add this line...

ws1.select

It will leave you to that sheet..

I have found and modified the code below, but it will not provide a proper hyperlink from the Tab Name or City.  It will from the Page Number.  Would you know how to modify this so that it will work by clicking on the City? The TOC is Sheet1, Handheld Info = Sheet2 and Handheld Barcodes = Sheet3.

Sub TOC()

 Dim s As Worksheet
 Dim r As Integer
 Dim c As Integer
 Dim sheetnum As Integer

 c = 1
 r = 1
 sheetnum = 2

ActiveSheet.Columns(c).Clear
 ActiveSheet.Columns(c + 1).Clear
 For Each s In ActiveWorkbook.Worksheets
   If s.Name <> ActiveSheet.Name Then
     If ActiveSheet.Cells(r, c).Text <> " " Then
'       ActiveSheet.Cells(r, c).Hyperlinks.Add Anchor:=Cells(r, c), Address:="", SubAddress:="'" & s.Name & "'!a1"
         ActiveSheet.Cells(r, c).Hyperlinks.Add Anchor:=Cells(r, c), Address:="", SubAddress:="'" & s.Name
       ActiveSheet.Cells(r, c).Value = ActiveSheet.Cells(r, c).Text
       ActiveSheet.Cells(r, c).Font.Underline = xlUnderlineStyleNone
       ActiveSheet.Cells(r, c + 1).Hyperlinks.Add Anchor:=Cells(r, c + 1), Address:="", SubAddress:="'" & s.Name & "'!a1"
       ActiveSheet.Cells(r, c + 1).Value = sheetnum
       ActiveSheet.Cells(r, c + 1).Font.Underline = xlUnderlineStyleNone
       r = r + 1
       sheetnum = sheetnum + 1
     End If
   End If
 Next s
ActiveSheet.Cells.EntireColumn.AutoFit
End Sub

Select allOpen in new window

Cook09

Cook09,

I will probably write a separate code and incorporate in my code, The only thing i want to understand is how do you want to set up the hyperlink?? Can you post me again your sample workbook with hyperlinks in it so that i can accordingly write the code for the same..

Saurabh...

Saurabh,

Here is the Worksheet with both codes integrated.  I will use this for the inclusion of Barcodes within each sheet. Would you also adjust the code so that the worksheet data for each sheet begins on B2, versus A1.

Cook09
Handhelds-2.xlsm

I have tried to close both of these...three times.  But, it won't close...

cook09

I will try to close again...may need administrator....

Cook090

I've requested that this question be closed as follows:

Accepted answer: 500 points for Saurabh Singh Teotia's comment #a40670774

for the following reason:

This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.

I have tried to close this three times already...this will be a fourth time.  Martin can you please explain why this is occurring?

Cook09

This is the fourth time trying to close.

Cook09