Formatting in-cell

[Mr_Phil]

Hi, I feel I should know this, but ...

I have data that was concantentated into one cell from two columns. Then it was paste as valued to cement it into place.

It is now, 2 lines in one cell. I need the second line to be a barcode and we have a working font for that so I applied it.

I tried to use the format painter to get the rest done and it is a no-go and I can't figure out why. I could highlight and change all the of items except there are a few thousand of them.

 

[6StringJazzer]

The format painter doesn't handle it when the source cell has mixed formats. A cell has an underlying format, even if you apply a different format to some characters, and it is the underlying format that is used by the painter.

This could be done with VBA with a bit more detail, like what fonts you are using, where your data is located. To test it I would have to have access to the barcode font. Is it available for free?

 

[Mr_Phil]

The format painter doesn't handle it when the source cell has mixed formats. A cell has an underlying format, even if you apply a different format to some characters, and it is the underlying format that is used by the painter.

This could be done with VBA with a bit more detail, like what fonts you are using, where your data is located. To test it I would have to have access to the barcode font. Is it available for free?

Yes. It is free as far as I know. Our IT provided the font. Look for AdvHc39a as a trutype font. You prefix and suffix the data to scan with an asterisk *.

I came to the same conclusion that a macro would be better. So, here is the macro and function just in case anyone is interested in dual formatting a single cell. I set it all up in a single column and then loop the macro until it hits an empty cell. From there you manipulate things as needed.

Sub FormatCells1()
    Dim ws As Worksheet
    Dim cell As Range
    Dim formatInfo As String
    Dim StartTime As Double
    Dim EndTime As Double
    
    StartTime = Timer
    
    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet
    
    ' Set the cell to the currently selected cell
    Set cell = ActiveCell
    
    ' Loop until you encounter a blank cell
    Do While Not IsEmpty(cell.Value)
        ' Call the FindAsteriskText function to get format info
        formatInfo = FindAsteriskText(cell)
        
        If formatInfo <> "No asterisk found in the cell." Then
            ' Extract the start position and length from the format info
            Dim startPos As Long
            Dim length As Long
            startPos = Val(Mid(formatInfo, InStr(formatInfo, "Start position: ") + 15, InStr(formatInfo, ", Length:") - InStr(formatInfo, "Start position: ") - 15))
            length = Val(Mid(formatInfo, InStr(formatInfo, "Length: ") + 8, InStr(formatInfo, ", End position:") - InStr(formatInfo, "Length: ") - 8))
            
            ' Apply specific formatting to the text within the start and length
            With cell.Characters(1, length).Font
                .Name = "Calibri"
                .FontStyle = "Regular"
                .Size = 9
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .ThemeFont = xlThemeFontNone
            End With
            'With cell.Characters(Start:=17, length:=10).Font
         With cell.Characters(Start:=startPos, length:=endPos).Font
            .Name = "AdvHC39a"
            .FontStyle = "Regular"
            .Size = 8
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
        End If
        
        ' Move to the next cell (one cell down)
        Set cell = cell.Offset(1, 0)
    Loop
    
    ' Message to announce the end of the run
    
    EndTime = Timer
    MsgBox "Formatting complete. End of the run."
    MsgBox "Macro execution time: " & (EndTime - StartTime) & " seconds"
End Sub

Function FindAsteriskText(rng As Range) As String
    Dim cellText As String
    Dim startPos As Long
    Dim endPos As Long
    Dim length As Long
    
    cellText = rng.Value
    startPos = InStr(1, cellText, "*")
    If startPos > 0 Then
        endPos = InStr(startPos + 1, cellText, "*")
        If endPos > 0 Then
            length = endPos - startPos + 1
            FindAsteriskText = "Start position: " & startPos & ", Length: " & length & ", End position: " & endPos
        Else
            FindAsteriskText = "Asterisk at the beginning but no closing asterisk found."
        End If
    Else
        FindAsteriskText = "No asterisk found in the cell."
    End If
End Function

 

[6StringJazzer]

Nice. I guess I don't need to write the code for you.