VBA: On clipboard: Replace all non alphanumeric characters for * and copy them to the clipboard

[MrNotepad]

Hi,

I need to do the following and I'd really thank you guys if you could give me a friendly hand with it:


From a selected range, copy and replace all non alphanumeric characters and spaces for * so that I have the result on the clipboard ready to be pasted somewhere. At the beginning and at the end of the text it should put a * also.

ie: Cell A1 has Roller#13$10 "Klein"
When I select cell A1 and run the Macro it will prepare the following on the clipboard to be pasted
somewhere. *Roller*13*10**Klein*
Cell A1 will keep its original text. It should do everything in the background and have the copied result
in the clipboard.

Best to you all,
Camilo

 

[BiocideJ]

You mean you want to paste them into cells of the same size as the selection?

I.e. if A1:B2 is selected (2x2 cells) when the macro is run then say you run the macro and select cell A4 then the result would be pasted in A4:B5?

Am I understanding correctly?

 

[BiocideJ]

OK, I am not going to be on here for much longer so I am going with the assumption that my previous post is accurate.
This changes the process for how this needs to be run so instead of writing directly to the clipboard, I am opening a temporary workbook and writing the updates there and then copying the data and closing the workbook. With ScreenUpdating off you can't even see it happening, but it works pretty smoothly.

I also included collections of everyone's improvement ideas.

Sub MNP()
    Dim s           As String
    Dim tempWB      As Workbook
    Dim srcRange    As Range
    Dim i           As Long
    
    Set srcRng = ActiveWindow.RangeSelection
    Application.ScreenUpdating = False
    Set tempWB = Workbooks.Add(1)
    
    For Each SelectedCll In srcRng
        s = UCase(SelectedCll.Text)
        
        For i = 1 To Len(s)
            If Mid(s, i, 1) Like "[!A-Za-z0-9]" Then Mid(s, i) = "*"
        Next i
        tempWB.Sheets(1).Range(SelectedCll.Address).Value = "*" & s & "*"
    Next SelectedCll
    
    tempWB.Sheets(1).Range(srcRng.Address).Copy
    tempWB.Close False
    Application.ScreenUpdating = True
    Set twmpWB = Nothing
End Sub

 

[MrNotepad]

Super, it works awesomely well. You couldnt have been more helpful.

God Bless

 

[BiocideJ]

Great. Credit shared all around.
I even learned something new myself in the process of answering your question.


BTW, I noticed a minor typo in my code, the last line

Set twmpWB = Nothing
should be
Set tempWB = Nothing

It won't cause any errors or problems most likely, but it is good convention to correctly set all objects to Nothing so they don't hang in memory.

 

[Rick Rothstein]

Here is a macro that will work without having to create/delete a hidden workbook (using shg's code as a base)...

Sub MNP()

  Dim R As Long, C As Long, I As Long
  Dim T1 As String, T2 As String, O As String
  Dim oDO As Object

  For R = 1 To Selection.Rows.Count
    For C = 1 To Selection.Columns.Count
      T1 = Selection.Cells(R, C).Text
      For I = 1 To Len(T1)
          If Mid(T1, I, 1) Like "[!A-Za-z0-9]" Then Mid(T1, I) = "*"
      Next I
      T2 = T2 & vbTab & "*" & T1 & "*"
    Next
    O = O & vbLf & Mid(T2, 2)
    T2 = ""
  Next
  O = Mid(O, 2)
  
  Set oDO = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  oDO.SetText O
  oDO.PutInClipboard

End Sub

 

[shg]

... can be replaced by this single line of code...

If Mid(s, i, 1) Like "[!A-Za-z0-9]" Then Mid(s, i) = "*"

I typically avoid the Like operator for speed considerations, but in this case, it's not only more compact, it's significantly faster. Thanks, Rick.

 

[snb_]

nor this one:

Sub M_snb()
   sn = Selection

   For j = 1 To UBound(sn)
      c00 = Replace(Replace(LCase(Join(Application.Index(sn, j, 0), vbTab)), "~", "*"), vbTab, "~")
      For jj = 1 To Len(c00)
          If Mid(c00, jj, 1) Like "[!a-z0-9~]" Then Mid(c00, jj, 1) = "*"
      Next
      c01 = c01 & vbLf & c00
  Next
  
  With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText Replace(mid(c01,2), "~", vbTab)
    .PutInClipboard
  End With
End Sub

 

[snb_]

since we are already working with the dataobject:

Sub M_snb()
  Selection.Copy
  
  With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .getfromclipboard
        c00 = Replace(Replace(Replace(.gettext, "~", "*"), vbCrLf, "~~"), vbTab, "~")

        For j = 1 To Len(c00)
           If Mid(c00, j, 1) Like "[!a-zA-Z0-9~]" Then Mid(c00, j, 1) = "*"
        Next
   
        .SetText Replace(Replace(c00, "~~", vbLf), "~", vbTab)
        .PutInClipboard
  End With
End Sub

 

[Rick Rothstein]

since we are already working with the dataobject:

Sub M_snb()
  Selection.Copy
  
  With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .getfromclipboard
        c00 = Replace(Replace(Replace(.gettext, "~", "*"), vbCrLf, "~~"), vbTab, "~")

        For j = 1 To Len(c00)
           If Mid(c00, j, 1) Like "[!a-zA-Z0-9~]" Then Mid(c00, j, 1) = "*"
        Next
   
        .SetText Replace(Replace(c00, "~~", vbLf), "~", vbTab)
        .PutInClipboard
  End With
End Sub

The code you posted in Message #17 works fine, but I cannot get the above code to work correctly... the original data gets pasted unchanged for me every time.

 

[snb_]

A small amendment:

Sub M_snb()
  Selection.Copy
  
  With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .getfromclipboard
        c00 = Replace(Replace(Replace(.gettext, "~", "*"), vbCrLf, "~~"), vbTab, "~")

        For j = 1 To Len(c00)
           If Mid(c00, j, 1) Like "[!a-z0-9~]" Then Mid(c00, j, 1) = "*"
        Next
   
        .Clear
        .SetText Replace(Replace(c00, "~~", vbLf), "~", vbTab)
        .PutInClipboard
  End With
  
  Sheet1.Paste Sheet1.Cells(20, 1)
End Sub