自動微距：橫跨整列特殊字符的去除（VBA）

Question

我們正在尋找的是在表面上很簡單：

我們希望能保持柱（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 

有沒有更好的方式來做到這一點？

非常感謝，

最大

Answer 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 

Answer 2

，我能想到的是使用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