自动宏：删除整个列中的特殊字符 (VBA)
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/12712372/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Auto Macro: Removal of Special Characters across entire column (VBA)
提问by user1717622
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.
除了下划线：“_”字符外，我们希望工作表的第 (1) 列没有所有特殊字符（即非字母数字字符）。
I found a solution in the format of a macro that will clear all special characters, to automate this macro, I used Worksheet_Change.
我找到了一个宏格式的解决方案，可以清除所有特殊字符，为了自动化这个宏，我使用了 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
最大限度
回答by Siddharth Rout
The fastest way that I can think of is using Findand Replace. See this example
我能想到的最快方法是使用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
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
回答by baldmosher
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.
这是我为做类似工作而编写的代码，希望有人可以使用它。为了其他目的而调整它很容易。就我而言，我想要一个函数来返回有效路径和/或文件名和/或 VBAProject 名称。它适用于 URL 和 UNC 路径（并尝试清理任何带有混合斜杠的路径）。您可以轻松指定额外的“禁止”字符，并根据自己的特定需求添加任何额外的布尔开关，或者您可以将其拆分为单独的函数。
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.
该函数还会检查最大字符串长度，如果文件名（不是路径）超过 128 个字符（对于 SharePoint 上传非常有用）或 VBA 对象名称超过 35 个字符，则该函数会裁剪或弹出消息框。
Cross-posted here: http://baldywritten.blogspot.com/2013/01/vba-macro-to-remove-special-characters.html
在这里交叉发布：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
