VBA to dynamically convert Font in cells to Barcode - Embed Font?

robertwp7472

robertwp7472

New member
Joined
Jul 22, 2016
Messages
86
Reaction score
0
Points
0
Location
Fox Island, WA
I want to create an xlsm with a control button to convert supplied data into a Bar-code Font.

The data will be pasted in each time used and can be anywhere from one row to 100+ rows. In order to work an Asterisk * must be added to both front and back of numbers/text and the columns for the Bar-coding need to be set @ a 36 point Font Size in order for printed version to be scan-able.

Can a Font be Embedded into a Macro/Spreadsheet so that anyone who uses it can convert even if Font is not installed on their machine?
Click to expand...

View attachment BC-Convert.xlsxForm

View attachment 3OF9.zipFont File
 
OK... So I tried my luck at using a combination of Macro Recorder and multiple online resources through Google and Then I used some of the knowledge I gained/gleamed working with NoS on two previous projects and I put together this code:

Code: 
Sub ConvertFont()
'Clear Pre-Existing Data if any
'Set Row 1 @ 50 Points & Freeze
'Copy Data from Colums A & B to D & F respectivly
'Convert Font in Cloumns E & G to 3 of 9 BarCode
'
'
' Clears Sheet For New Input
    Cells.Delete

'Set Row 1
    Rows("1:1").RowHeight = 50
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
       
'Perform Copy/Paste Operation
       Columns("A:A").Copy
          Columns("D:D").Paste
       Columns("B:B").Copy
          Columns("F:F").Paste

'Insert Asterick Before and after Cell Value
Dim r As Long
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = ("D" & r)
Set rng2 = ("F" & r)
        
      If rng1.Value <> "" Then rng1.Value = "*" & rng1.Value
      If rng2.Value <> "" Then rng2.Value = rng2.Value & "*"
      End If
      End If

'Perform 2nd Copy/Paste Operation after Asterick addition
       Columns("D:D").Copy
          Columns("E:E").Paste
       Columns("F:F").Copy
          Columns("G:G").Paste

'Change Font of E & G to 3of9; Font Size to 36; Column Width to 36
       Range("E1,G1").Select
    With Selection.Font
        .Name = "3 of 9 Barcode"
        .FontStyle = "Regular"
        .Size = 36
        .ColumnWidth = 36
    End With

'Center Align Entire WorkSheet
    With ActiveWindow
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
    End With
End Sub

It has some problems that I am not able to figure out completely. I am getting a "Type Mismatch" error for this: Set rng1 = ("D" & r) and I think its because I need to modify code with a For-Next Loop and I don't know the correct Syntax.

Any help would be greatly appreciated.
 
Last edited:
I realized one mistake already. I need to separate the "Clear Data" function from the rest because it will do no good to paste in the data I want to augment just to hit the run command button and have it clear the worksheet. That's my DUH moment.
 
I Made some more changes to the code to make it a bit cleaner (I think) Now I am getting a compile error while trying to set up the ranges. Here is what I have:
Code: 
Sub ClearPage()
' Clears Sheet For New Input
    Cells.Delete
    
''Set Row 1 @ 50 Points & Freeze
    Rows("1:1").RowHeight = 50
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    
End Sub
Sub ConvertFont()

'Copy Data from Colums A & B to D & F respectivly
'Convert Font in Cloumns E & G to 3 of 9 BarCode
'Insert Asterisk Before and after Cell Value

Dim lr As Long
Dim rng1, rng2, rng3, rng4, rng5, rng6 As Range
[COLOR=#ff0000][B]Set rng1 = ("A2:A" & lr)[/B][/COLOR][COLOR=#008000][B] ' this is where I get error[/B][/COLOR][COLOR=#ff0000][/COLOR]
Set rng2 = ("B2:B" & lr)
Set rng3 = ("D2:D" & lr)
Set rng4 = ("F2:F" & lr)
Set rng5 = ("E2:E" & lr)
Set rng6 = ("G2:G" & lr)

'Perform Copy/Paste Operation
'From https://www.excelcampus.com/vba/copy-paste-cells-vba-macros/
    rng3.Value = rng1.Value
    rng4.Value = rng2.Value

'Insert Asterisks
    If rng3.Value <> "" Then rng3.Value = "*" & rng3.Value
    End If
    If rng4.Value <> "" Then rng4.Value = rng4.Value & "*"
    End If

'Perform 2nd Copy/Paste Operation after Asterick addition
       rng5.Value = rng3.Value
       rng6.Value = rng4.Value

'Change Font of E & G to 3of9; Font Size to 36; Column Width to 36
       Range("rng5, rng6").Select
    With Selection.Font
        .Name = "3 of 9 Barcode"
        .FontStyle = "Regular"
        .Size = 36
        .ColumnWidth = 36
    End With

'Center Align Entire WorkSheet
    With ActiveWindow
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
    End With
End Sub

Anyone?
 
In the same vein as what you've posted. Did you mean to use arrays?
Note the comments.
Code: 
Sub ConvertFont()
     'Copy Data from Colums A & B to D & F respectively
     'Convert Font in Cloumns E & G to 3 of 9 BarCode
     'Insert Asterisk Before and after Cell Value
     
    Dim lr As Long
    Dim rng1 As Variant, rng2 As Variant    'poor names, should be like arr1 and arr2
    Dim rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range
    Dim cel As Range    'used for individual 1 cell ranges
    
'determine last row
lr = Range("A" & Rows.Count).End(xlUp).Row

' fill the arrays
    rng1 = Range("A2:A" & lr).Value
    rng2 = Range("B2:B" & lr).Value
' set the ranges
    Set rng3 = Range("D2:D" & lr)
    Set rng4 = Range("F2:F" & lr)
    Set rng5 = Range("E2:E" & lr)
    Set rng6 = Range("G2:G" & lr)
     
' use the arrays to fill two of the ranges
    rng3 = rng1
    rng4 = rng2
     
'Insert Asterisks
' put bar code in adjacent cells
    For Each cel In rng3
        If cel.Value <> "" Then
            cel.Offset(0, 1).Value = "*" & cel.Value & "*"
        End If
    Next cel
    
    For Each cel In rng4
        If cel.Value <> "" Then
            cel.Offset(0, 1).Value = "*" & cel.Value & "*"
        End If
    Next cel
 
'Change Font of E & G to 3of9; Font Size to 36; Column Width to 36
With Application.Union(rng5, rng6)
    .Font.Name = "3 of 9 Barcode"
    .Font.Size = 36
    .ColumnWidth = 36
End With
 
 'Center Align Entire WorkSheet >>>> That's 17,179,869,184 cells
' **************************************************************
' *        the workbook you posted uses 160 cells              *
' *           only apply to usedrange at most                  *
' *                                                            *
' **************************************************************
        With ActiveSheet.UsedRange
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
        End With

End Sub
 
Once again... Thank You NoS. Woks great. Now... What did I do wrong here? When I run this it literally clears everything including the Control buttons. I need it to affect everything south of Row 1.
Code: 
Sub ClearPage()
 ' Clears Sheet For New Input    
 Cells.Delete      

''Set Row 1 @ 50 Points & Freeze     
Rows("1:1").RowHeight = 50     
With ActiveWindow        
 .SplitColumn = 0         
.SplitRow = 1     
End With    
 ActiveWindow.FreezePanes = True      
End Sub
 
Did you mean to use arrays?
Click to expand...
No response.
I very much doubt you did. I know I wouldn't have.

As a simpleton subscribing to the KISS system (Keep It Simple, Stupid), I'd have just used a couple loops.
Code: 
Sub BarCode_Setup()

    Dim lr As Long
    Dim rng As Range
    Dim cel As Range

With Sheets("Sheet1")
    'last row
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    
    'deal with colA
    Set rng = .Range("A2:A" & lr)
    For Each cel In rng
        If cel.Value <> "" Then
            cel.Offset(0, 3).Value = cel.Value
            cel.Offset(0, 4).Value = "*" & cel.Value & "*"
        End If
    Next cel
    
    'deal with colB
    Set rng = .Range("B2:B" & lr)
    For Each cel In rng
        If cel.Value <> "" Then
            cel.Offset(0, 4).Value = cel.Value
            cel.Offset(0, 5).Value = "*" & cel.Value & "*"
        End If
    Next cel
    
    'format first bar code column
    With .Range("E2:E" & lr)
        .Font.Name = "3 of 9 Barcode"
        .Font.Size = 36
        .EntireColumn.AutoFit
    End With
    
    'format second bar code column
    With .Range("G2:G" & lr)
        .Font.Name = "3 of 9 Barcode"
        .Font.Size = 36
        .EntireColumn.AutoFit
    End With

End With
    
End Sub


Current issue:
Cells.Delete deletes all 17 billion plus cells on the sheet replacing them with cells using Excel defaults
ie: no content, no formatting, default height and width.
Activesheet.Columns("C:G").Delete will delete just those few columns to the right of column B.
 
Honestly, I did not know I was attempting to use arrays. As I stated in my comments, I built the code I had from a conglomeration of bits and pieces from some of the stuff I learned from you on Dock Schedule & Best Door and from looking stuff up on google etc. I knew it was "Un-perfect Code" to say the least but at my level of skill I was not able to determine what I had done wrong I just knew I was headed in a somewhat correct direction.

Now, dealing with the Clear Sheet Function what I want to do I delete everything in the active sheet except for Row 1 so that my control Buttons aren't swept up in the deletion. Would this do the trick?
Code: 
Range("A2", Cells.SpecialCells(xlLastCell)).Delete

The Data in Columns A & B will be being manually replaced at every use of the Macro so they do not need to be save either.
 
Right click on your button(s) > Format Control > Properties > select Don't move or size with cells > OK.

Your buttons will now remain when using Cells.Delete
 
Everything works great; however, now I find that I need to set the active sheet to "Text" rather than general or number format. How would I do this and where would I insert it? I am thinking it should be one of the very first functions.
 
How would I do this
Click to expand...
select one cell, start macro recorder, format cell as text, stop macro recorder, look at what was produced.
Replace selection with the range required.

where would I insert it? I am thinking it should be one of the very first functions.
Click to expand...
you won't know the range to format until the end and can then use .Usedrange
 
Well... I tried that and it worked once the data was in place however the Damage was already done. Several of the numbers that require a "Leading Zero" had been automatically changed by Excel and the Zero removed. I tried this:
Code: 
    ActiveSheet.Select
    With Selection.NumberFormat = "@"
    End With
I inserted this after the command that clears the sheet in an attempt to set up the Text Formatting prior to inserting the data that is going to be augmented by the functional macro but it did not work. It didn't cause an error, but it didn't work either.
 
but it did not work. It didn't cause an error, but it didn't work either.
Click to expand...
if the instruction was run, I'm pretty sure it worked.
Check the cells that were highlighted (selected), or if none were, check the cell that was active at the time it ran.
 
OK ... I think I understand. This will only work if an area is selected. What I did was I ran this with the Macro that runs with the Clear Sheet function in order tp "Preset" the sheet to accept input and then see as text. I ran the macro, and then checked the formatting on several cells and they were still in the Excel default of "General" which will remove any leading zeros.

I understand that the .usedrange only works after the fact. I know this is overkill on the area being handled but would
Code: 
cells.NumberFormat = "@"
do what I need and preset the sheet?
 
That's the super simple way and will definitely work. The overkill will be more than 17 billion cells.

If you limit to just the columns you'll be using, the overkill will be reduced to 7 or 8 million cells.

If you calculate the number of rows of data that will be imported and use that in combination with the columns that will be used, there will be zero overkill.

In one of your previous projects it was necessary to determine the number of rows in the source file.
Can you not do the same in this project?
 
This was my solution to limit the overkill. I figured that I will almost never be using more than 150 -200 rows if even that so I set a range.
Code: 
Range("A2:G200").NumberFormat = "@"

Now I want to set the print area from D2 to last cell of G used, with Landscape orientation, margins @ 0, set to 1 page width, automatic height. Once this is set I can create a final command button with a simple print command attached.

I did this in Macro Recorder and that is some seriously ugly code, don't really want to use that and it obviously won't allow for a variable size sheet. Can you point me in the right direction for this?
 
The macro recorder tends to include everything, even if most of it is defaults that could be omitted.

Have never used VBA to set the print area of a sheet, I've always printed manually.
Have opened files posted on the forums that are .xlsx (no VBA), selected print and they display landscaped.
So the print settings must be stored and 'remembered' by Excel, although I don't know if deleting all cells affects that.

Google is your friend.
 
I'll do some research and post my results...Who knows maybe I can help you this time. :cool2: I do think its going to require me creating a stand-alone sub and tying it to a command button. I am pretty sure from what you have already taught me that I will need to use code that defines the last row. I will put something together and post it for your viewing. Thanks for your help so far.
 
Here is what I found
Code: 
Sub setprintarea()

'Posted by Richard Winfield on January 14, 2002 on Mr. Excel
'Merged with Posting by VoG (Mr. Excel MVP) Feb 21st, 2009
'and from RichNH on www.experts-exchange.com

Dim myrange As String

myrange = Cells(Rows.Count, 7).End(xlUp).Address

   With ActiveSheet.PageSetup
      'Set Print area
      .PrintArea = "$D$2:" & myrange
      
      'Set Margins
      .LeftMargin = 0
      .RightMargin = 0
      .TopMargin = 0
      .BottomMargin = 0
      
      'Set Orientation on paper
      .CenterHorizontally = True
      .CenterVertically = False
      .Orientation = xlLandscape
      .Zoom = False
      .FitToPagesWide = 1
      .FitToPagesWide = False
        
   End With

End Sub

Any simplification would be great. Testing now.
 
You must log in or register to reply here.
Back
Top