Temporarily change strings

[Un-Do Re-Do]

I want to select a number of cells, temporarily make changes as noted below, and show the changes in a format such as a picture in this case.
CHANGE 1: Change the dot character "." with a hashtag "#".
CHANGE 2: [Preamble: Assume all characters have a weighting of 1 except the hashtag character "#" which has a weighting of 0.5. So when counting the number of characters, 2 of "#" equal 1 of any other character.] .......... Then colour each character green if the count of that character is a whole number (for weighting of 1 and 0.5 respectively) or an even whole number (for weighting of 2 and 1 respectively). Otherwise colour red.

The code below is a work in progress and based on a sample from elsewhere. It does not incorporate Change 2.

* Note that when the code is run, the image width is only the size of the column and may not fit the total number of characters. Is there a way to make it fit the entire length of the data. Maybe a completely different method to display the data as opposed to the current method?


EXAMPLE

Cell data
a+b + ..1-jmq. - qw.erty
d-k .2np. 2k2m..j3
h+j .582. 2k2m...jk

Image required when macro is run
a+b + ##1-jmq# - qw#erty
d-k #2np# 2k2m##j3
h+j #582# 2k2m###jk

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ZoomCell 1.75
End Sub

Private Sub ZoomCell(ZoomIn As Single)
    Dim s As Range
    Set s = Selection

    'Get rid of any existing zoom pictures
    For Each p In ActiveSheet.Pictures
        If p.Name = "ZoomCell" Then
            p.Delete
            Exit For
        End If
    Next

    'Create a zoom picture
Dim c As Range, x As Long
For Each c In Selection
Dim result As String
c = Replace(c, ".", "#")
Next

    s.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ActiveSheet.Pictures.Paste.Select
    With Selection
        .Name = "ZoomCell"
        With .ShapeRange
            .ScaleWidth ZoomIn, msoFalse, msoScaleFromTopLeft
            .ScaleHeight ZoomIn, msoFalse, msoScaleFromTopLeft
            With .Fill
                .ForeColor.SchemeColor = 8
                .Visible = msoTrue
                .Solid
                .Transparency = 0.75
            End With
        End With
    End With
    s.Select
    Set s = Nothing

For Each c In Selection
c = Replace(c, "#", ".") 'Reverts back to original once deselected
Next

End Sub

[karedog]

Maybe :

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.EnableEvents = False
    Test
  Application.EnableEvents = True
End Sub
Private Sub Test()
  Dim cell As Range, a, i As Long, p As Long, s As String, isGreen As Boolean
  On Error Resume Next
     ActiveSheet.Pictures("ZoomCell").Delete
  On Error GoTo 0
  a = Selection.Value
  For Each cell In Selection
      With cell
        If Len(.Value) Then
           s = Replace$(.Value, ".", "#") & "#"
           .Value = Left$(s, Len(s) - 1)
           p = 1
           isGreen = True
           For i = 1 To Len(s)
               If Mid$(s, i, 1) = "#" Then
                  .Characters(p, i - p).Font.Color = IIf(isGreen, 65280, 255)
                  p = i
                  isGreen = Not isGreen
               End If
           Next i
        End If
      End With
  Next cell
  With Selection
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Offset(, 1).Select
    With .Parent.Pictures.Paste
      .Select
      .Name = "ZoomCell"
    End With
    .Value = a
    .Font.Color = 0
  End With
End Sub

[Un-Do Re-Do]

@karedog
Thx, this works quite well.
But for some reason the more the macro is invoked, the slower it gets, after about 10 runs Excel freezes up.
Is this because the pictures are stored somewhere?

[karedog]

You are welcome.

No, there is only one picture affected (the "ZoomCell" picture), so it uses a very tiny system resources.
It seemed that you have another code running or other things that cause the slow down.
If you can't locate the cause by yourself, you need to upload your workbook, so I can find the cause.

[Un-Do Re-Do]

Please see attached.
Also can I change zoom level?

[karedog]

I tried the your attached file, it run very smooth on my PC, nothing is wrong.
I modify the code to avoid the event enabler and disabler, don't know if this could help on your PC.
I also add the Zoom feature to the code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Test 1.75
End Sub
Private Sub Test(ZoomIn As Single)
  Dim cell As Range, a, i As Long, p As Long, s As String, isGreen As Boolean
  On Error Resume Next
     ActiveSheet.Pictures("ZoomCell").Delete
  On Error GoTo 0
  a = Selection.Value
  For Each cell In Selection
      With cell
        If Len(.Value) Then
           s = Replace$(.Value, ".", "#") & "#"
           .Value = Left$(s, Len(s) - 1)
           p = 1
           isGreen = True
           For i = 1 To Len(s)
               If Mid$(s, i, 1) = "#" Then
                  .Characters(p, i - p).Font.Color = IIf(isGreen, 65280, 255)
                  p = i
                  isGreen = Not isGreen
               End If
           Next i
        End If
      End With
  Next cell
  With Selection
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With .Parent.Pictures.Paste
      .Name = "ZoomCell"
      .Top = Selection.Offset(, 1).Top
      .Left = Selection.Offset(, 1).Left
      .Width = .Width * ZoomIn
      .Height = .Height * ZoomIn
      .Select
    End With
    .Value = a
    .Font.Color = 0
  End With
End Sub

[Un-Do Re-Do]

Thx once more.

[karedog]

You are welcome, thanks for marking the thread as solved.

Regards