Delete objects and replace spaces left after that with symbols in black (color)

Question

I want to delete objects and replace the spaces left after that with symbols in black (color)

Option Explicit

Sub delete_objects()
Dim i As Long, k As Long, arr(), text As String, dic As Object
    ReDim arr(1 To Sheet1.Shapes.Count, 1 To 2)
    For i = 1 To Sheet1.Shapes.Count
        If Sheet1.Shapes(i).Line.EndArrowheadStyle = 2 Then
            k = k + 1
            arr(k, 2) = Sheet1.Shapes(i).TopLeftCell.Address
            Sheet1.Shapes(i).Name = "temp_" & k
            arr(k, 1) = "temp_" & k
        End If
    Next i
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To k
        Sheet1.Shapes(arr(i, 1)).Delete
        If Not dic.exists(arr(i, 2)) Then
            text = Sheet1.Range(arr(i, 2)).Value
            text = Replace(text, String(5, " "), " " & ChrW(8594), , 1)
            Sheet1.Range(arr(i, 2)).Value = text
            dic.Add arr(i, 2), ""
        End If
    Next i
    Set dic = Nothing
End Sub

The above VBA code replaces the objects with a symbol (an arrow pointing right) in the color of whatever number or text that preceded it before the macro was run but the spaces remain. Please tweak the code above to help remove the spaces left behind after that as well. Please also make sure that your solution acts only on column J and skips blank/empty cells also. It should also recolor all the symbols black (color). The image of the result should be like this - the third line and second last line in column J, as compared to the same in column L

If I tweak it to this:-

Sub delete_objects()
Dim i As Long, k As Long, arr(), text As String, dic As Object, pos As Long
ReDim arr(1 To Sheet1.Shapes.Count, 1 To 2)
For i = 1 To Sheet1.Shapes.Count
    If Sheet1.Shapes(i).TopLeftCell.Address Like "$J$*" And Sheet1.Shapes(i).Line.EndArrowheadStyle = 2 Then
        k = k + 1
        arr(k, 2) = Sheet1.Shapes(i).TopLeftCell.Address
        Sheet1.Shapes(i).Name = "temp_" & k
        arr(k, 1) = "temp_" & k
    End If
Next i
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To k
    Sheet1.Shapes(arr(i, 1)).Delete
    If Not dic.exists(arr(i, 2)) Then
        text = Sheet1.Range(arr(i, 2)).Value
        text = Replace(text, String(5, " "), " " & ChrW(8594), , 1)
        text = Application.WorksheetFunction.Trim(text)
        Sheet1.Range(arr(i, 2)).Value = text
        pos = InStr(1, text, ChrW(8594))
        If pos Then
            With Sheet1.Range(arr(i, 2))
                .Characters(pos, 1).Font.Color = RGB(0, 0, 0)
                .Characters(pos - 1, 3).Font.Strikethrough = False
            End With
        End If
        dic.Add arr(i, 2), ""
    End If
Next i
Set dic = Nothing
End Sub

in some lines, for example, in the second last row of column J of the image, it has recolored the text black, which I don't want.

Answer 1

This VBA code did everything I wanted:-

Option Explicit

Sub delete_objects()
Dim i As Long, k As Long, start As Long, pos As Long, text As String, arr(), dic As Object
    ReDim arr(1 To Sheet1.Shapes.Count, 1 To 2)
    For i = 1 To Sheet1.Shapes.Count
        If Sheet1.Shapes(i).TopLeftCell.Address Like "$J$*" And Sheet1.Shapes(i).Line.EndArrowheadStyle = 2 Then
            k = k + 1
            arr(k, 2) = Sheet1.Shapes(i).TopLeftCell.Address
            Sheet1.Shapes(i).Name = "temp_" & k
            arr(k, 1) = "temp_" & k
        End If
    Next i
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To k
        Sheet1.Shapes(arr(i, 1)).Delete
        If Not dic.exists(arr(i, 2)) Then
            With Sheet1.Range(arr(i, 2))
                text = .Value
                start = InStr(1, text, String(5, " "))
                If start > 0 Then
                    pos = start
                    Do While pos < Len(text) + 1 And Mid(text, pos, 1) = " "
                        pos = pos + 1
                    Loop
                    .Characters(start + 1, 1).Insert ChrW(8594)
                    .Characters(start + 1, 1).Font.Color = RGB(0, 0, 0)
                    .Characters(start + 1, 1).Font.Strikethrough = False
                    .Characters(start + 3, pos - start - 3).Delete
                End If
            End With
            dic.Add arr(i, 2), ""
        End If
    Next i
    
    Set dic = Nothing
End Sub