Как удалить определенные символы, используя скрипт Excel VBA

Question

Следующий скрипт VBA избавляет от нежелательных символов, но, к сожалению, только от NUMBERS.

Не могли бы вы мне помочь, нужно также избавиться от букв, как в приведенном ниже примере таблицы (выделено жирным шрифтом).

Диапазон может быть от 0 до 15000+ клеток

............................................... ......

a new a york a times a

b new b york b times b

c new c york c watertown c ny c

6 пр. 6 новый 6 йорк 6 город 6

............................................... .......

Сценарий VBA:

Sub Remove()

Application.ScreenUpdating = False
Dim R As RegExp, C As Range
For Each C In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If R Is Nothing Then
Set R = New RegExp
R.Global = True
R.Pattern = "\D"
C.Offset(0, 1) = R.Replace(C, "")
R.Pattern = "\d"
C = R.Replace(C, "")
End If
Set R = Nothing
Next C
Application.ScreenUpdating = True
End Sub

EDIT1

Sub Remove()
Call BackMeUp

Dim cell As Range
Dim RE As Object
Dim Whitecell As Range
Dim strFind As String, strReplace As String
Dim lLoop As Long
Dim Loop1 As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
Range("A3:L3").Select
Selection.Delete Shift:=xlUp
'--------------------------------------------------Remove JUNK
Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
On Error Resume Next
For lLoop = 1 To 100
    strFind = Choose(lLoop, "~?»", "~®", "~.", "~!", "~ï", "~-", "~§", "~$", "~%", "~&", "~/", "~\", "~,", "~(", "~)", "~=", "~www", "~WWW", "~.com", "~.net", "~.org", "~{", "~}", "~[", "~]", "~ï", "~¿", "~½", "~:", "~;", "~_", "~µ", "~@", "~#", "~'", "~|", "~€", "~ä", "~ö", "~ü", "~Ä", "~Ü", "~Ö", "~+", "~<", "~>", "~nbsp", "~â", "~¦", "~©", "~Â", "~–", "~¼", "~?")
    strReplace = Choose(lLoop, " ")

    Selection.Replace What:=strFind, Replacement:=strReplace, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Next lLoop
'--------------------------------------------------Remove Numbers
Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
On Error Resume Next
For Loop1 = 1 To 40
    strFind = Choose(lLoop, "~1", "~2", "~3", "~4", "~5", "~6", "~7", "~8", "~9", "~0")
    strReplace = Choose(Loop1, " ")

    Selection.Replace What:=strFind, Replacement:=strReplace, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Next Loop1
'--------------------------------------------------Remove Single Letters
Set RE = CreateObject("vbscript.regexp")
RE.Global = True
RE.MultiLine = True
RE.Pattern = "^[a-z]\b | \b[a-z]\b"

For Each cell In Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    cell.Value = RE.Replace(cell.Value, "")

Next

'--------------------------------------------------Remove WHITE SPACES

For Each Whitecell In Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Whitecell = WorksheetFunction.Trim(Whitecell)
Next Whitecell

'--------------------------------------------------Remove DUPES

ActiveSheet.Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear

'--------------------------------------------------Copy to B - REPLACE ALL WHITE IN B

Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    Selection.Copy
    Range("B3:B" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    ActiveSheet.Paste
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Columns("A:L").EntireColumn.AutoFit

'--------------------------------------------------END
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Range("a1").Select
End Sub

Answer 1

РЕДАКТИРОВАТЬ ( удалил оригинальный ответ, так как он был неприменим после получения дополнительной информации о том, что вы хотели, но оставив совет)

• Вы создаете/ уничтожение объекта RE в каждой ячейке, что дорого / необязательно
  • Если другие пользователи будут использовать функцию, создайте объект внутри кода вместо добавления ссылок
  • Нет необходимости устанавливатьв конце функции regex обнулять - переменные автоматически выводятся из памяти в конце функции
  • Улучшение именования переменных и использование правильного отступа может улучшить читабельность и упростить редактирование
  • Добавьте параметр multiline, если в ваших ячейках есть разрывы строк.
  • Возможно, вы захотите использовать вариантный массив при работе с большим количеством ячеек

UDPATE 2

Основываясь на одном из приведенных ниже комментариев, здесь показано, как получить только вхождения двух или более строчных символов и сингла.промежутки между ними.Вместо того, чтобы заменить то, что вы НЕ хотите, я лично считаю, что хороший способ - извлечь то, что вы DO хотите.Я немного поделился нижеприведенной функцией на этом сайте, так как она действительно полезна.Вот пример того, как вызвать его для содержимого столбца A и поместить результаты в столбец B.

Sub test()

' Show how to run this on cells in A and transpose result in B
Dim varray As Variant
Dim i As Long

Application.ScreenUpdating = False
varray = Range("A1:A15000").Value

For i = 1 To UBound(varray, 1)
    varray(i, 1) = RegexExtract(varray(i, 1), "([a-z]{2,})", " ")
Next

Range("B1").Resize(UBound(varray, 1)).Value = _
Application.WorksheetFunction.Transpose(varray)

Application.ScreenUpdating = True

End Sub

И убедиться, что это в модуле:

Function RegexExtract(ByVal text As String, _
                      ByVal extract_what As String, _
                      Optional seperator As String = "") As String

Dim i As Long
Dim j As Long
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")

RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)

For i = 0 To allMatches.Count - 1
    For j = 0 To allMatches.Item(i).submatches.Count - 1
        result = result & seperator & allMatches.Item(i).submatches.Item(j)
    Next
Next

If Len(result) <> 0 Then
    result = Right$(result, Len(result) - Len(seperator))
End If

RegexExtract = result

End Function

Answer 2

Я переписал ваш код ниже, чтобы

• RegExp создается только один раз. Ваш текущий код создает новый объект, а затем уничтожает его для каждой тестируемой ячейки, поскольку она находится внутри вашего цикла
• В приведенном ниже коде используется вариантный массив для минимизации времени обработки при манипулировании каждым значением ячейки. Константа VbNullString немного быстрее, чем "".
• Вы можете использовать более простое \ w в регулярном выражении, чтобы соответствовать любому a-z0-9

• поздняя привязка к объекту RegExp избавляет от необходимости обращаться к третьей стороне за установкой ссылки, а для параметра ignore case устанавливается значение true, что делает замену нечувствительной к регистру

       Sub Remove()
       Dim R As Object
       Dim C As Range
       Dim lngrow As Long
       Dim rng1 As Range
       Dim X
       Set R = CreateObject("vbscript.regexp")
       With R
         .Global = True
         .Pattern = "^\w\s|\b\w\b"
         .ignoreCase = True
       End With
       Application.ScreenUpdating = False
       Set rng1 = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
       X = rng1.Value2
       For lngrow = 1 To UBound(X, 1)
         X(lngrow, 1) = R.Replace(X(lngrow, 1), vbNullString)
       Next lngrow
       rng1.Value2 = X
       Application.ScreenUpdating = True
        End Sub
  

Answer 3

Ваш "R.Pattern =" \ d "- единственная строка, которую вам нужно изменить." \ D "- это регулярное выражение, описывающее" цифру ".

Я бы предложил заменить "\ d" на "^ [a-z0-9] | [a-z0-9] \ b" в качестве отправной точки.