need help in macro

[sksanjeev786]

Hi Team,

I have a macro which applies color on each cell but while changing the color I don't want "Ctrl" data font size increase I want same as per template
and data are in same cell i.e 2.9 and Ctrl 67% are in same cell...

can anyone help me to get the macro as per image 1 where ctrl data font size remain same and greay data font also remain same as per image 1

First image i did manully and 2nd image with Macro..

Public Sub HighlightBoldWhitenAndRemoveLetters()

    Dim ActiveShape As Shape
    Dim shp As Shape
    Dim objTable As Table
    Dim targetColumn As Long
    Dim targetRow As Long
    Select Case Application.ActiveWindow.Selection.Type
        Case ppSelectionShapes, ppSelectionText
            For Each shp In Application.ActiveWindow.Selection.ShapeRange
                Set ActiveShape = shp
                Exit For
            Next shp
        Case Else
            MsgBox "There is no shape currently selected!", vbExclamation, "No Shape Found"
            Exit Sub
    End Select
    If ActiveShape.HasTable Then
        Set objTable = ActiveShape.Table
        targetColumn = 2
        targetRow = 4
        For targetRow = 4 To objTable.Rows.Count - 1
            For targetColumn = 2 To objTable.Columns.Count
                Dim cell As cell
                Set cell = objTable.cell(targetRow, targetColumn)
                With cell.Shape.TextFrame.TextRange
                    Dim cellText As String
                    cellText = .text
                    Dim checkText As String
                    If InStr(1, cellText, "Ctrl") > 0 Then
                        checkText = Left(cellText, InStr(1, cellText, "Ctrl") - 1)
                    Else
                        checkText = cellText
                    End If
                    
                    If InStr(1, LCase(checkText), "p") > 0 Then
                        cell.Shape.Fill.ForeColor.RGB = RGB(79, 138, 16)
                        .Font.Bold = msoTrue
                        .Font.Color.RGB = RGB(255, 255, 255) ' White font color
                        .text = Replace(cellText, "p", "")
                    ElseIf InStr(1, LCase(checkText), "r") > 0 Then
                        cell.Shape.Fill.ForeColor.RGB = RGB(255, 150, 0)
                        .Font.Bold = msoTrue
                        .Font.Color.RGB = RGB(255, 255, 255) ' White font color
                        .text = Replace(cellText, "r", "")
                    ElseIf InStr(1, LCase(checkText), "q") > 0 Then
                        cell.Shape.Fill.ForeColor.RGB = RGB(204, 51, 51)
                        .Font.Bold = msoTrue
                        .Font.Color.RGB = RGB(255, 255, 255) ' White font color
                        .text = Replace(cellText, "q", "")
                    Else
                        cell.Shape.Fill.Visible = msoFalse
                        .Font.Bold = msoFalse
                        .Font.Color.RGB = RGB(0, 0, 0) ' Black font color
                    End If
                End With
            Next targetColumn
        Next targetRow
    Else
        MsgBox "The selected shape is not a table!", vbExclamation, "Table Not Found"
    End If
End Sub

,

 

[Micron]

I haven't worked much with shape text frames but have formatted only parts of strings in a cell. For that you set the font attributes of the .Characters property.
Example:

Select Case Right(rng, 1)
               Case "p"
                    rng.Characters(InStr(rng, " ") + 1).Font.Color = vbGreen
               
               Case "q"
                    rng.Characters(InStr(rng, " ") + 1).Font.Color = vbRed
                    
               Case "r"
                    rng.Characters(InStr(rng, " ") + 1).Font.Color = RGB(153, 255, 153)
          End Select

I see that a textframe has a characters property also, so maybe try working with the font properties of .Characters instead of .Font of the cell? Something like

cell.Shape.TextFrame.TextRange.Characters.Font.Color =
except that you need to isolate the portion of the cell string that you want to format. String functions such as Mid or left would be the way to go.