Create Several Worksheets from One - VBA

Attached is a workbook that has four worksheets. This is what the workbook currently contains.
1. HandHeld Info
  a. Column A is the City Name that new tabs (worksheets) will be Named.

2. HandHeld Barcodes
   a. Currently, it creates a Barcode for each of the City's in HandHeld Info.
      b. SN: = Serial Number   FL = Flash ID    ID under Barcode is the Registration Number

3. Albuquerque
    a. Sample of the first city in HandHeld Info.
     b. Need one like this for each City listed in Column A of HandHeld Info.

4. Abuquerque Barcodes
    a. This one is optional as I'm not sure how to create a seperate barcode page for each City in HandHeld Info.
     b. If it can be done, that would be great, if not, then I can just create each one manually, with a template of some kind.

 (I'll be back on 3-16)
Handhelds.xlsm
Cook09Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

 
Rodney EndrigaData AnalystCommented:
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
0
 
Saurabh Singh TeotiaCommented:
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

Open in new window


Saurabh...
0
 
Rodney EndrigaData AnalystCommented:
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
0
Cloud Class® Course: Certified Penetration Testing

This CPTE Certified Penetration Testing Engineer course covers everything you need to know about becoming a Certified Penetration Testing Engineer. Career Path: Professional roles include Ethical Hackers, Security Consultants, System Administrators, and Chief Security Officers.

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

Cook09
0
 
Cook09Author Commented:
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
0
 
Saurabh Singh TeotiaCommented:
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..
0
 
Cook09Author Commented:
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

Open in new window




Cook09
0
 
Saurabh Singh TeotiaCommented:
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...
0
 
Cook09Author Commented:
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
0
 
Saurabh Singh TeotiaCommented:
Their you go use this code..it will automatically create TOC sheet on it's own whenever you run this code along with hyperlink to the respective sheet...

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, ws4 As Worksheet
    Dim ws3 As Worksheet, r As Range, lr1 As Long
    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

    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "TOC"

    Set ws4 = ActiveSheet

    ws4.Range("a1").Value = ws1.Name
    ws4.Range("b1").Value = 2
    ws4.Range("a2").Value = ws2.Name
    ws4.Range("b2").Value = 3


    ws4.Hyperlinks.Add Anchor:=ws4.Range("a1"), Address:="", SubAddress:="'Handheld Info'!A1", TextToDisplay:=ws4.Range("A1").Value
    ws4.Hyperlinks.Add Anchor:=ws4.Range("a2"), Address:="", SubAddress:="'Handheld Barcodes'!A1", TextToDisplay:=ws4.Range("A2").Value


    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

                lr1 = ws4.Cells(Cells.Rows.Count, "a").End(xlUp).Row + 1
                ws4.Range("A" & lr1).Value = Trim(cell.Value)
                ws4.Range("B" & lr1).Value = Sheets.Count
                ws4.Hyperlinks.Add Anchor:=ws4.Range("a" & lr1), Address:="", SubAddress:="'" & ws3.Name & "'!A1", TextToDisplay:=ws4.Range("A" & lr1).Value
                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
    ws4.Select
    ws4.Cells.EntireColumn.AutoFit
    ws4.Range("A1").Select

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
End Sub

Open in new window


Saurabh...
0

Experts Exchange Solution brought to you by ConnectWise

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
 
Cook09Author Commented:
I have tried to close both of these...three times.  But, it won't close...

cook09
0
 
Cook09Author Commented:
I will try to close again...may need administrator....

Cook090
0
 
Martin LissOlder than dirtCommented:
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.
0
 
Cook09Author Commented:
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
0
 
Cook09Author Commented:
This is the fourth time trying to close.

Cook09
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.