4

The following VBA script gets rid of unwanted characters but unfortunately only NUMBERS.

Could you please assist me, It needs to rid letters too as in the table example(bolded) below.

the Range could be anywhere from 0 to 15000+ cells

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

a new a york a times a

b new b york b times b

c new c york c watertown c ny c

6 ave 6 new 6 york 6 city 6

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

The VBA script:

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
Improve this question

3 Answers 3

Reset to default
4

EDIT (deleted original answer as it was not applicable after recieving more info on what you wanted, but leaving advice)

  • You are creating/destroying the RE object every cell, which is expensive/unnessessary
    • If other users will use the function, create the object inside the code instead of adding references
    • There is no need to set the regex object to nothing at the end - variables are released from memory at the end of the function automatically
    • Improving your variable naming and using proper indentation could help improve readability and make it easier to edit
    • Add the multiline option in case your cells have line breaks inside them.
    • You might want to use a variant array if working with a lot of cells

UDPATE 2

Based one the comments below, here is how to get only occurances of two or more lowercase characters and the single spaces in-between. Instead of replacing what you DON'T want, I personally think a good way is to extract what you DO want. I have shared the below function quite a bit on this site as it's really useful. Here's an example of how to call it on the contents of Column A and put the results in Column 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

And make sure this is in the module:

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
Improve this answer
Sign up to request clarification or add additional context in comments.

17 Comments

Thanks Issun, This is what I ended up using but I'd like to know if there's a possibility of deleteing EVERYTHING except "lower case letters" IN ONE GO. So just keeping "white spaces" between words that consist of 2 letters or more....At the moment I'm deleting unwanted characters such as @,?, $ ect.. then numbers, then single leftover letters and finaly trimming unwanted spaces. The whole process takes (with 10,000 rows) approx 25 seconds. Please see my working EDIT1 above. Thankyou
Udpated with solution to do that. It's actually really simple once you think about it in terms of what you want and not in terms of what you don't want. :)
I disagree that using "what you do want" is superior to "what you don't want" in this case. While it is true that retaining what you do want can sometimes be simpler (ie retain only numbers), in this case the retain pattern is of the same complexity as the exclude pattern. More importantly, the exclude technique "nukes" all the unwanted pieces in a single regexp Replace, the technique above requires a loop to tie back all the individually required pieces from the RegExp Execute. Plus where's your string function? :)
I don't mean that extracting what you want is superior to replacing that which you don't want: What i mean is that it's more simple logically to work out. Replace functions are genearlly costly, so I think contactenating the captures will work out to be about the same performance wise, if not faster. Plus extracting in this case is better at avoiding corner cases that the regex replace may not work in. I'm a little lost on what you mean about a string function, RegexExtract returns a string.
(Please note I only decided to go to extract after the update on what the OP was wishing to achieve) My tests show both methods (replace vs extract) take similar time, but extract goes the extra step to trim the result and has no corner cases. I'll stick to my opinion that extract is a better chocie in this case, but i do respect your opinion. :)
|
3

Your "R.Pattern = "\d" is the only line you need to change. The "\d" is a regular expression describing a "digit".

I would suggest changing "\d" to "^[a-z0-9] | [a-z0-9]\b" as a starting point.

Improve this answer

4 Comments

I overlooked the first "\D" and "C.Offset...". I don't see that they're of any use.
Correct phatingers, no use at all and your code works very well..BIG thanks.
+1 If the answer worked, click the arrow on the upper left to 'accept' the answer :)
Thanks for the feedback! Once you're satisfied with an answer to a question you've asked here, you should "Accept" it. It rewards the person answering with reputation points, increases your own reputation, and maintains your percentage of answers accepted.
3

I rewrote your code below so that

  • The RegExp is only created once. Your current code creates a new object then destroys it for each cell being tested as it is inside your loop
  • The code below uses a variant array to minimise process time when manipulating each cell value. The constant VbNullString is slightly quicker than "".
  • you case use the simpler \w in a regex to match any a-z0-9

  • late binding on the RegExp object avoids the need to ak a third party to set a reference, setting ignore case to true makes your replacement case insenstive

         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
Improve this answer

5 Comments

Updated as per my working code ... in my copying and editing .Pattern = "^\w\s|\b\w\b" was mistyped as .Pattern = "^\w\s|\b|w\b"
Just tried this again Brettdj..sorry again absolutely nothing happens :(
Thx for your persitence. It works fine for me when I copy your data and run this in both xl03 and xl10, so its unclear to me why it may not be working for you. Hopefully Issun has you sorted
Your script does work - my fault - and reduces the overall time by 2 secs and cpu to 50% :) Thanks brettdj...this was all very interesting :)
Thanks for coming back on this Sammy :)

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.