0

私たちが探しているものは、表面上は非常に単純です。

ワークシートの column(1) には、アンダーコアの「_」文字を除いて、すべての特殊文字 (つまり、英数字以外の文字) がないようにします。

すべての特殊文字をクリアするマクロの形式で解決策を見つけました。このマクロを自動化するには、Worksheet_Change を使用しました。

ただし、ワークシート オブジェクト内からすべてを解決するソリューションをお勧めします (以下に示す 2 段階のソリューションとは対照的です)。

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

私が考えることができる最速の方法は、とを使用すること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
于 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 に答える