Concatenated the values of cells in same cell but keeping the font of the last cell as free30f9(barcode)

[jhonty4]

Hi, the objective of my project was to generate labels from an excel file which will be downloaded from ERP software. With the help of mr excel i was able to do everything that I wanted to and even generate the labels. Now the final nail in the coffin is that the cell G which contains the barcode is not displaying as barcode but in the same font as all the other values. Is there any way that can make sure that the objective can be achieved by printing the labels with the barcode
If the fonts in the same cell cannot be different we could also try to divide the cells and print barcode into that. Column G contains the barcode. TIA

Sub AveryLabels4014()

''''    Print onto Avery Compatible 4014 labels (1 7/16" x 4")
''''    Caveat:  You may need to adjust row height/column width and/or margins to fit your labels


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow As Long, i As Long, j As Long, NoCols As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Filtur As String
Dim prtArea As Range


Set ws1 = ActiveSheet
Set ws2 = Sheets.Add(after:=Worksheets(Worksheets.Count))
LastRow = ws1.Cells(Rows.Count, "E").End(xlUp).Row
Filtur = InputBox("Please Enter Filter Criterion")


''''    Filter and copy data to new sheet
On Error GoTo errHandler:
With ws1
    .AutoFilterMode = False
    .Range("A6:G6").AutoFilter
    .Range("A6:G6").AutoFilter Field:=1, Criteria1:=Filtur
    .Range("B7:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Range("B1") 'this needs to be changed such that the Column G contains barcode font
    .AutoFilterMode = False
End With


''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & vbCrLf & _
                       .Cells(i, 6) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
    Next i
    Columns("B:G").Delete
End With


''''Resize to one across
j = 1
NoCols = 1
For i = 1 To LastRow Step NoCols
    ws2.Cells(j, "A").Resize(1, NoCols).Value = _
    Application.Transpose(ws2.Cells(i, "A").Resize(NoCols, 1))
    j = j + 1
Next
Range(ws2.Cells(j, "A"), ws2.Cells(LastRow, "A")).Clear
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set prtArea = ws2.Range("A1:C" & LastRow)


''''    Format cells
With ws2.Cells
    .RowHeight = 103.5 'Adjust as necessary
    .ColumnWidth = 54.57 'Adjust as necessary
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
End With


''''    Set Print Settings
Application.PrintCommunication = False
With ws2.PageSetup
    .LeftMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .RightMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .TopMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .BottomMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .Orientation = xlPortrait
    .PaperSize = xlPaperLetter 'adjust to match your printer type
    .FitToPagesWide = 1
    .FitToPagesTall = False
    .PrintArea = prtArea.Address
End With
Application.PrintCommunication = True


Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub


errHandler:
    ws1.AutoFilterMode = False
    ws2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Sorry, your filter criterion did not find a match." & vbCrLf & _
        "Please try again."
End Sub

 

[jhonty4]

Hi PG
this is exactly what I wanted. The test works as well. I tried to imitate the test code in my code but there is something that I am missing. Can you have a look ? It is not showing any error just that the font is not changing

''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & .Cells(i, 6)
                              
        .Cells(i, 1).Value = Cells(i, 1).Value
        length = Len(.Cells(i, 1).Value)
        
        .Cells(i, 1) = Cells(i, 1) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
                
        With .Cells(i, 1).Characters(length + 1).Font
                .Name = "Arial"
                .Size = 30
        End With


        
Next i
    'Columns("B:G").Delete
    
End With

 

[pgc01]

Hi

This works for me.

I wrote some data in Sheet2!A1:G10. The code concatenates all to column A.

I used your code, just adjusted the range.

Please try

'    Concatenate data from A1:G10 to A1:A10
Sub Test()
Dim ws2 As Worksheet
Dim lLength As Long, lLastRow As Long, i As Long

Set ws2 = Worksheets("Sheet2")

lLastRow = 10
With ws2
    For i = 1 To lLastRow
        .Cells(i, 1) = .Cells(i, 2) & vbLf & .Cells(i, 3) & vbLf & _
                       .Cells(i, 4) & vbLf & .Cells(i, 5) & .Cells(i, 6)
                              
        lLength = Len(.Cells(i, 1).Value)
        
        .Cells(i, 1) = Cells(i, 1) & vbLf & .Cells(i, 7)
                
        With .Cells(i, 1).Characters(lLength + 1).Font
                .Name = "Arial"
                .Size = 30
        End With

Next i
Columns("B:G").Clear

End With
End Sub

 

[jhonty4]

Thanks a lot PGC. Very helpful