delete everything from the first occurrence of a number till the end of the cell using VBA

Dear Experts:

For the selected cells I would like to run  a macro that performs the following action:

Search for the occurrence of the first number and then delete everything from the first occurrence till the end of the cell

Before:
Mouth Gag, Roser-Koenig, 16 Cm, Sinus Lift
Mouth Gag, Roser-Koenig, 19 Cm Lower
Chest Support for Mouth Gag 38-198-00

After:
Mouth Gag, Roser-Koenig,
Mouth Gag, Roser-Koenig,
Chest Support for Mouth Gag

Help is much appreciated. Thank you very much in advance.

Regards, Andreas
Andreas HermleTeam leaderAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieAnalyst Assistant Commented:
Andreas

Where is the data located?

If the data you posted was in A1:A3 you could try this.
Dim cl As Range
Dim rng As Range
Dim regexp As Object
Dim mat As Object

    Set regexp = CreateObject("vbscript.regexp")
 
    regexp.Pattern = "[0-9]"
    
    Set rng = Range("A1:A3")
    
    For Each cl In rng.Cells
         Set mat = regexp.Execute(cl.Value)
         If mat.Count = 1 Then
            cl.Offset(, 1).Value = Left(cl.Value, mat(0).firstindex)
         End If
    Next cl

Open in new window

0
Rgonzo1971Commented:
Hi,

pls try to eliminate the last space as well
Sub CellRegexSimple()
Dim regex As Object

Set regex = CreateObject("VBScript.RegExp")

    With regex
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "(.*?)\s?\d+"
    End With
    
    For Each c In Selection
        Set mtches = Nothing
        Set mtches = regex.Execute(c.Text)
        If Not mtches Is Nothing Then
            c.Formula = mtches(0).submatches(0)
        End If
    Next
Set regex = Nothing
End Sub

Open in new window

REgards
1
Rgonzo1971Commented:
and if you want to delete the last comma as well then use
.Pattern = "(.*?),?\s?\d+"

Open in new window

0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Saqib Husain, SyedEngineerCommented:
Without VBA you can try this ARRAY formula

=LEFT(A2,MIN(IF(ISNUMBER(VALUE(MID(A2,ROW(OFFSET(A1,0,0,LEN(A2))),1))),ROW(OFFSET(A1,0,0,LEN(A2))),99999))-1)
2
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
It's always a good practice to test if the string contains the desired pattern in it before actually manipulating the string so that if the string doesn't contain the set pattern, it won't throw an error.
 
You may try it like this...
Sub DeleteStringPart()
Dim RE As Object
Dim cell As Range

Set RE = CreateObject("VBScript.RegExp")
    With RE
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "(.*?)\s?\d+"
    End With
    
    For Each cell In Selection
        If RE.test(cell.Value) Then
            cell.Value = RE.Execute(cell.Value)(0).submatches(0)
        End If
    Next cell
Set RE = Nothing
End Sub

Open in new window

0
Rgonzo1971Commented:
corrected code
Sub CellRegexSimple()
Dim regex As Object

Set regex = CreateObject("VBScript.RegExp")

    With regex
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "(.*?)\s?\d+"
    End With
    
    For Each c In Selection
        Set mtches = regex.Execute(c.Text)
        If mtches.Count > 0 Then
            c.Formula = mtches(0).submatches(0)
        End If
    Next
Set regex = Nothing
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Andreas HermleTeam leaderAuthor Commented:
Dear both, your codes work best for me. Thank you very much for your great help. I really appreciiate it.

To all the others. Thank you very much for your swift and professional help.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Andreas! Glad we could help.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.