VBA support : need to remove extra space

[sksanjeev786]

Hi Team,

I have a VBA and it is working well but I need some amendments on the below macro..

Note "p","q" and "r" indicate Arrow

So my data in PPT table are like
34 p (this is fine after running macro I am getting 1 space 34 ▲)

But in below scenario I am getting
Need to Fix
34 p A (In this case I am getting extra space in both 34 ▲ A as don't want space and it should come as 34▲A (colors are already defined)
34 q (in this case I am getting extra space running macro on PPT 34 ▼ but I need 34 ▼ with 1 space only)

Public Sub HighlightBoldAndFormatArrows()

    Dim ActiveShape As Shape
    Dim shp As Shape
    Dim objTable As Table
    Dim targetColumn As Long
    Dim targetRow As Long
    Dim cell As cell
    Dim textRange As textRange
    Dim cellText As String
    Dim i As Long
    Dim arrow As String
    Dim arrowColor 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
        For targetRow = 3 To objTable.Rows.Count - 1
            For targetColumn = 2 To objTable.Columns.Count
                Set cell = objTable.cell(targetRow, targetColumn)
                Set textRange = cell.Shape.TextFrame.textRange
                cellText = textRange.Text

                arrowColor = RGB(0, 0, 0)

                For i = 1 To Len(cellText)
                    Select Case Mid(cellText, i, 1)
                        Case "p"
                            textRange.Characters(i, 1).Text = ChrW(9650)
                            arrowColor = RGB(0, 210, 0)
                        Case "q"
                            textRange.Characters(i, 1).Text = ChrW(9660)
                            arrowColor = RGB(225, 0, 0)
                    End Select

                    If Mid(cellText, i, 1) = "p" Or Mid(cellText, i, 1) = "q" Then
                        With textRange.Characters(i, 1).Font
                            .Name = "Arial (Body"
                            .Color.RGB = arrowColor
                            .Bold = msoTrue
                        End With
                    End If
                Next i

            Next targetColumn
        Next targetRow
    Else
        MsgBox "The selected shape is not a table!", vbExclamation, "Table Not Found"
    End If
End Sub

 

[Scott Huish]

Not sure I understand exactly what you need but you can use the VBA Trim function or if you need to remove extra spaces within text you can use the Worksheet function Trim:

For example to show the difference:

Sub test()
Dim s As String
s = " This  is a test "
MsgBox Trim(s)
MsgBox Application.WorksheetFunction.Trim(s)
End Sub

 

[sksanjeev786]

Not sure I understand exactly what you need but you can use the VBA Trim function or if you need to remove extra spaces within text you can use the Worksheet function Trim:

For example to show the difference:

Sub test()
Dim s As String
s = " This  is a test "
MsgBox Trim(s)
MsgBox Application.WorksheetFunction.Trim(s)
End Sub

Hi Sir,

I tried the above macro but it is not working for me.

let me simplify my questions

With Macro:

34 ▲ (Pulled correct via Macro)
34 ▲ A ( I need 34▲A without any space some logic needs to change in the existing macro)
34 ▼ (Need 1 Space after arrow 34 ▼)

Could you please help us by changing the existing macro as Macro works well for me just needs few tweaks.

Regards
Sanjeev