0

我们要寻找的东西表面上很简单：

我们希望保持工作表的第 (1) 列不包含所有特殊（IE 非字母数字字符），但下划线：“_”字符除外。

我找到了一个宏格式的解决方案，可以清除所有特殊字符，为了自动化这个宏，我使用了 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

有一个更好的方法吗？

非常感谢，

最大限度

4

2 回答 2

2

我能想到的最快方法是使用Findand 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

跟进

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    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
于 2012-10-03T16:18:44.380 回答
1

这是我为做类似工作而编写的代码，希望有人可以使用它。为其他目的调整它很容易。就我而言，我想要一个函数来返回有效的路径和/或文件名和/或 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("\\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
于 2013-01-04T12:13:43.063 回答