0

What we are looking for is quite simple on the surface:

We are looking to keep column(1) of our worksheet free of all special (I.E non-alphanumeric characters) with the exception of the undercore: "_" character.

I found a solution in the format of a macro that will clear all special characters, to automate this macro, I used Worksheet_Change.

I would however prefer a solution that solved everything from within the worksheet object (as opposed to the two step solution we see below).

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range.c) Is Nothing Then Remove_Characters
End Sub

Which then calls to action the Macro:

Sub Remove_Characters()
Dim c As Range
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\W"
For Each c In Cells.Range("A1:A1000")
c.Value = Replace(.Replace(c.Value, ""), "_", "")
Next c
End With
    Range("A1").Select
End Sub

Is there a better way to do this?

Many Thanks,

Max

4
  • You are using this CreateObject("vbscript.regexp") but never using RegExp? Oct 3, 2012 at 16:06
  • If you are creating an object that means you want to use it... Right? Else why would you create it? Anyways, I have a different suggestion in mind. Posting an answer shortly... Oct 3, 2012 at 16:10
  • I am only just learning this language so your thoughts and insights are very useful. Oct 3, 2012 at 16:17
  • 2
    The OP is using With and the second Replace has a period, so they are using the regexp... Oct 3, 2012 at 18:10

2 Answers 2

2

The fastest way that I can think of is using Find and Replace. See this example

Option Explicit

'~~> Add/Remove as per your requirements
Const splChars As String = "!@#$%^&()"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long

    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
        For i = 1 To Len(splChars)
            Range("A1:A1000").Replace What:=Mid(splChars, i, 1), _
            Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Next i
    End If

LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

FOLLOWUP

Further to my comment, if you have special characters like * or ~ then you will have to use this code

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    NOTE: Whenever you are working with Worksheet_Change event. Always switch   '
'    Off events if you are writing data to the cell. This is required so that    '
'    the code doesn't go into a possible endless loop                            '
'                                                                                '
'    Whenever you are switching off events, use error handling else if you get   '
'    an error, the code will not run the next time.                              '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit

'~~> Add/Remove as per your requirements
Const splChars As String = "~!@#$%^&*()"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long
    Dim SearchString As String

    '~~> Incorporate Error Handling
    On Error GoTo Whoa

    '~~> Switch Off Events
    Application.EnableEvents = False

    '~~> Check if there is any change in A1:A1000
    If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
        '~~> Loop throught the special characters one by one
        For i = 1 To Len(splChars)
            SearchString = Mid(splChars, i, 1)

            '~~> Check if the character is ~ or *. If it is then append "~" to it
            Select Case SearchString
                Case "~", "*": SearchString = "~" & SearchString
            End Select

            '~~> Do a simple Find And Replace in all cells in one go
            '~~> without looping
            Range("A1:A1000").Replace What:=SearchString, _
            Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Next i
    End If
'~~> Exit gracefully
LetsContinue:
    Application.EnableEvents = True
    Exit Sub
'~~> Trap the error
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub
8
  • NOTE:= If your splChars string contains a * then there will be a slight modification to the above code. Oct 3, 2012 at 16:29
  • Works good, but this seems to be deleting alphanumeric characters too? Oct 3, 2012 at 16:30
  • I see now, the * was the problem....would there be modifications for other characters too? Oct 3, 2012 at 16:31
  • What is the string that you are using? Const splChars As String = "!@#$%^&()" Oct 3, 2012 at 16:32
  • that's fantastic Mr Rout! It does indeed what we need it to do, although the solution is rather more complex than I expected it would be. Oct 3, 2012 at 16:40
1

This is the code I've written to do a similar job, hopefully someone can make use of it. It's easy enough to tweak this for other purposes. In my case I wanted a single function to return a valid path and/or filename and/or VBAProject name. It works with both URL and UNC paths (and tries to clean up any paths with mixed slashes). You can specify additional "forbidden" characters easily and add any extra boolean switches for your own specific needs, or you could just split into separate functions.

The function also checks the maximum string length and either crops or pops up a message box if a filename (not path) exceeds 128 characters -- very useful for SharePoint uploads -- or a VBA object name exceeds 35 characters.

Cross-posted here: http://baldywritten.blogspot.com/2013/01/vba-macro-to-remove-special-characters.html

Function fn_Clean_Special(str As String, CropLength As Boolean _
    , Optional VBObjectName As Boolean) As String
'v1.03 2013-01-04 15:54
'removes invalid special characters from path/file string
', True stops message box warnings and autocrops string
'     [, True] also removes spaces and hyphens and periods (VBA object)
'~ " # % & * : < > ? { | } ..   / \   -

Dim b As Integer, c As Integer, pp As String
Const tt As String = "fn_Clean_Special"
Dim sc(0 To 18) As String
sc(0) = "~"
sc(1) = Chr(34)  ' Chr(34) = " quotemark
sc(2) = "#"
sc(3) = "%"
sc(4) = "&"
sc(5) = "*"
sc(6) = ":"
sc(7) = "<"
sc(8) = ">"
sc(9) = "?"
sc(10) = "{"
sc(11) = "|"
sc(12) = "}"
sc(13) = ".."
'slashes for filenames and VB Object names
sc(14) = "/"
sc(15) = "\"
'hyphen & space & period for VB Object names
sc(16) = "-"
sc(17) = " "
sc(18) = "."

'remove special characters from all
For b = 0 To 13
    str = Replace(str, sc(b), vbNullString)
Next b

'check filename length (length AFTER the LAST slash max 128 chars)
b = InStr(1, str, sc(14))  'look for fwd slash
If b > 0 Then
    str = Replace(str, sc(15), sc(14))  'remove all back slashes
    Do Until b = 0  'until last slash found
        c = b       'c is position of last slash
        b = b + 1                   'next position
        b = InStr(b, str, sc(14))   'next position
    Loop
Else  'no fwd slashes
    b = InStr(1, str, sc(15))  'look for back slash
    If b > 0 Then
        str = Replace(str, sc(14), sc(15))  'remove all fwd slashes
        Do Until b = 0  'until last slash found
            c = b       'c is position of last slash
            b = b + 1                   'next position
            b = InStr(b, str, sc(15))   'next position
        Loop
    End If
End If
'c is position of last slash, or 0 if no slashes
If Len(str) - c > 128 Then
    If CropLength = True Then
        str = Left(str, 35)
    Else
        pp = "WARNING: filename > 128 chars"
        MsgBox pp, vbCritical, tt
    End If
End If

'remove slashes from filenames only
If c > 0 Then
    For b = 14 To 15
        str = Left(str, c) & Replace(Right(str, Len(str) - c), sc(b), vbNullString)
    Next b
End If


If VBObjectName = True Then
'remove slashes and swap hyphens & spaces & periods for underscore in VB object name
    Const scUS As String = "_"
    For b = 14 To 18
        str = Replace(str, sc(b), scUS)
    Next b
'then remove invalid characters from start of string
    Dim c1 As String
    c1 = Left(str, 1)
    Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)
        str = Right(str, Len(str) - 1)
        c1 = Left(str, 1)
    Loop
'remove double underscore
    Do While InStr(str, scUS & scUS) > 0
        str = Replace(str, scUS & scUS, scUS)
    Loop
    'check object name length (max 35 chars)
    If Len(str) > 35 Then
        If CropLength = True Then
            str = Left(str, 35)
        Else
            pp = "WARNING: object name > 35 chars"
            MsgBox pp, vbCritical, tt
        End If
    End If
End If

fn_Clean_Special = str

End Function

Debug Window results:

?fn_clean_special("\\server\path\filename.xls", True)
\\server\path\filename.xls

?fn_clean_special("\\server\path\filename.xls", True, True)
server_path_filename_xls

?fn_Clean_Special("\\special character\testing   for \VBproject.xls", True, True)
special_character_testing_for_VBpro
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.