自动宏:删除整个列中的特殊字符 (VBA)

Question

我们正在寻找的东西表面上非常简单：

我们希望保持工作表的第 （1） 列没有所有特殊（即非字母数字字符），但核心下："_"字符除外。

我找到了宏格式的解决方案，可以清除所有特殊字符，为了自动化这个宏，我使用了Worksheet_Change。

但是，我更喜欢从工作表对象中解决所有问题的解决方案（而不是我们在下面看到的两步解决方案）。

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

然后调用宏：

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

有没有更好的方法可以做到这一点？

非常感谢，

麦克斯

Answer 1

我能想到的最快的方法是使用 Find 和 Replace .请参阅此示例

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

随访

根据我的评论，如果您有特殊字符，例如*或~，那么您将不得不使用此代码

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    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

Answer 2

这是我为做类似工作而编写的代码，希望有人可以使用它。 出于其他目的调整它很容易。 就我而言，我希望单个函数返回有效的路径和/或文件名和/或 VBAProject 名称。 它适用于 URL 和 UNC 路径（并尝试清理任何带有混合斜杠的路径）。 您可以轻松指定其他"禁止"字符，并根据自己的特定需求添加任何额外的布尔开关，或者您可以拆分为单独的函数。

该函数还会检查最大字符串长度，如果文件名（不是路径）超过 128 个字符（对于 SharePoint 上传非常有用）或 VBA 对象名称超过 35 个字符，则会裁剪或弹出消息框。

交叉发布在这里：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

调试窗口结果：

?fn_clean_special("\serverpathfilename.xls", True)
\serverpathfilename.xls
?fn_clean_special("\serverpathfilename.xls", True, True)
server_path_filename_xls
?fn_Clean_Special("\special charactertesting   for VBproject.xls", True, True)
special_character_testing_for_VBpro