Excel - Modify existing code to insert a Barcode and formatting into worksheet(s)

Attached is a file with a VBA Module (CreateNewDataSheets) that needs modified. The code will create a new worksheet for each city group within "HandHeld Info."  It also creates a Table of Contents.  The workbook only contains the first City created.

This city cotains a mockup of how the individual data should be formatted and a Barcode is also added (Column G).  The Font for the barcode is 3 of 9 Barcode. Currently, no barcode is inserted when the code runs.

This how all of the City Pages should look after the code is run.  I would also like for the barcode formula to actually be added to the barcode cells.

Cook09
Handhelds-2.xlsm
Cook09Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
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.

Saurabh Singh TeotiaCommented:
Cook09,

Use this version of the code...
Option Explicit

Sub CreateNewSheets()
    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("b2").Value = ws1.Name
    ws4.Range("c2").Value = 2
    ws4.Range("b3").Value = ws2.Name
    ws4.Range("c3").Value = 3


    ws4.Hyperlinks.Add Anchor:=ws4.Range("b2"), Address:="", SubAddress:="'Handheld Info'!A1", TextToDisplay:=ws4.Range("B2").Value
    ws4.Hyperlinks.Add Anchor:=ws4.Range("b3"), Address:="", SubAddress:="'Handheld Barcodes'!A1", TextToDisplay:=ws4.Range("B3").Value


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

    'Sets Tab Name
    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)
                    ActiveSheet.Cells.EntireColumn.ColumnWidth = 15
                    ActiveWindow.DisplayGridlines = False
                Else
                    ActiveSheet.Name = cell.Value
                    ActiveSheet.Cells.EntireColumn.ColumnWidth = 15
                    ActiveWindow.DisplayGridlines = False
                End If

                Set ws3 = ActiveSheet

                'Adds to TOC
                lr1 = ws4.Cells(Cells.Rows.Count, "b").End(xlUp).Row + 1
                ws4.Range("B" & lr1).Value = Trim(cell.Value)
                ws4.Range("C" & lr1).Value = Sheets.Count
                ws4.Hyperlinks.Add Anchor:=ws4.Range("b" & lr1), Address:="", SubAddress:="'" & ws3.Name & "'!B2", TextToDisplay:=ws4.Range("B" & lr1).Value
                '                ws4.Hyperlinks.Add Anchor:=ws4.Range("c" & lr1), Address:="", SubAddress:="'" & ws3.XXX & "'!C2", TextToDisplay:=ws4.Range("C" & lr1).Value
                ws1.Range("A1:G1").Copy ws3.Range("B2")
            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, "b").End(xlUp).Row + 1

            ws1.Range("A" & cell.Row & ":G" & cell.Row).Copy ws3.Range("B" & lr)
            ws3.Range("B" & lr & ":H" & lr).Font.Size = 11


            If Application.WorksheetFunction.CountIf(r, cell.Value) = Application.WorksheetFunction.CountIf(rng, cell.Value) Then
                ws3.Range("G:G").Insert
                ws3.Range("G2").Value = "Registration Barcode"
                lr = ws3.Cells(Cells.Rows.Count, "b").End(xlUp).Row
                ws3.Range("G3:G" & lr).Formula = "=""*""&B3&""*"""
                ws3.Cells.EntireColumn.AutoFit
            End If


            Set ws3 = Nothing
        End If



    Next cell

    ws4.Select
    ws4.Cells.EntireColumn.AutoFit
    ActiveSheet.Cells.Select
    ActiveWindow.DisplayGridlines = False
    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

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:
Saurabh,

The code overall looks fine, but I can't seem to find the right syntax for:

'                ws3.Range("G3:G" & lr).Formula = "=""*""&F3&""*"""
                ws3.Range("G3:G" & lr).Formula = "=""" * "" & "F"& lr & "" * """"
               ws3.Range("G" & lr).Font = "3 of 9 Barcode"
Could you help with this?
0
Saurabh Singh TeotiaCommented:
You dont need to it lr..leave to f3 only like shown in my code...

Also for barcode the code will be...

  ws3.Range("G3:G" & lr).Font  .Name = "3 of 9 Barcode"

And this line will remain as it's

    ws3.Range("G3:G" & lr).Formula = "=""*""&F3&""*"""

Don't worry excel will auto update it's formula when row changes...
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Cook09Author Commented:
Saurabh,

Everything looks good, but may I ask for one more item? Is there a way to set up all of the sheets to have a left and right margin set at .2"?  Maybe something at the end.  I would like for a certain portion to print, and regular margins won't work.

Thanks,

Cook09
0
Saurabh Singh TeotiaCommented:
Quick question you want the left margin at .2? or you want the margin of only of the data in the selection to be aligned at .2?
0
Cook09Author Commented:
The data margins for the entire workbook.  They can be at .2 or .25, but to have what I want to print, I need smaller margins.  If I knew how it was structured, I could play with the margins.

Cook09
0
Saurabh Singh TeotiaCommented:
Use this version of the code..

Sub CreateNewSheets()
    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("b2").Value = ws1.Name
    ws4.Range("c2").Value = 2
    ws4.Range("b3").Value = ws2.Name
    ws4.Range("c3").Value = 3


    ws4.Hyperlinks.Add Anchor:=ws4.Range("b2"), Address:="", SubAddress:="'Handheld Info'!A1", TextToDisplay:=ws4.Range("B2").Value
    ws4.Hyperlinks.Add Anchor:=ws4.Range("b3"), Address:="", SubAddress:="'Handheld Barcodes'!A1", TextToDisplay:=ws4.Range("B3").Value


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

    'Sets Tab Name
    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)
                    ActiveSheet.Cells.EntireColumn.ColumnWidth = 15
                    ActiveWindow.DisplayGridlines = False
                Else
                    ActiveSheet.Name = cell.Value
                    ActiveSheet.Cells.EntireColumn.ColumnWidth = 15
                    ActiveWindow.DisplayGridlines = False
                End If

                Set ws3 = ActiveSheet

                'Adds to TOC
                lr1 = ws4.Cells(Cells.Rows.Count, "b").End(xlUp).Row + 1
                ws4.Range("B" & lr1).Value = Trim(cell.Value)
                ws4.Range("C" & lr1).Value = Sheets.Count
                ws4.Hyperlinks.Add Anchor:=ws4.Range("b" & lr1), Address:="", SubAddress:="'" & ws3.Name & "'!B2", TextToDisplay:=ws4.Range("B" & lr1).Value
                '                ws4.Hyperlinks.Add Anchor:=ws4.Range("c" & lr1), Address:="", SubAddress:="'" & ws3.XXX & "'!C2", TextToDisplay:=ws4.Range("C" & lr1).Value
                ws1.Range("A1:G1").Copy ws3.Range("B2")
            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, "b").End(xlUp).Row + 1

            ws1.Range("A" & cell.Row & ":G" & cell.Row).Copy ws3.Range("B" & lr)
            ws3.Range("B" & lr & ":H" & lr).Font.Size = 11


            If Application.WorksheetFunction.CountIf(r, cell.Value) = Application.WorksheetFunction.CountIf(rng, cell.Value) Then
                ws3.Range("G:G").Insert
                ws3.Range("G2").Value = "Registration Barcode"
                lr = ws3.Cells(Cells.Rows.Count, "b").End(xlUp).Row
                ws3.Range("G3:G" & lr).Formula = "=""*""&B3&""*"""
                ws3.Cells.EntireColumn.AutoFit
                With ws3.PageSetup
                    .LeftMargin = Application.InchesToPoints(0.2)
                    .RightMargin = Application.InchesToPoints(0.2)
                End With
            End If


            Set ws3 = Nothing
        End If



    Next cell

    ws4.Select
    ws4.Cells.EntireColumn.AutoFit
    ActiveSheet.Cells.Select
    ActiveWindow.DisplayGridlines = False
    ws4.Range("A1").Select

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

Open in new window


Saurabh...
0
Cook09Author Commented:
I've tried to close this twice with an A.  But, it doesn't seem to be taking..

Cook09
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.