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?
 
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
 
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
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

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