Using RegExp to keep only uppercase letters in a string - regex

Question

I have a column of strings from which I want to extract the uppercase words then past in another column. The words are always in the beginning of the string. For example:
APPLE ORANGE_20 lbs_15 ------> APPLE ORANGE
BANANA_10 lbs_30 -----------------> BANANA
GRAPE MANGO 30lbs_o ----------> GRAPE MANGO
This is what I have so far but I am having a hard time setting the Pattern to get the output needed:
Sub ExtractUPPERCASE()
Dim re As Object, mc As Object
Dim r As Range, c As Range
Dim s As String
Dim wbdata As Workbook
Dim wsData As Worksheet
Set wbdata = Workbooks("trial1")
Set wsData = wbdata.Worksheets("Final Data")
wsData.Activate
Set r = wsData.Range("D1", Cells(Rows.Count, "D").End(xlUp))
Set re = CreateObject("vbscript.regexp")
With re
.Global = True
.ignorecase = False
.MultiLine = True
.Pattern = "^\s*([A-Z\W]+\b)\W+([\w\s]+)"
'.Pattern = "([^a-z]+|[^0-9]+|(?=.*[^\w_]))" I tried this pattern but it didn't get what i want
End With
For Each c In r
s = c.Text
If re.test(s) = True Then
Set mc = re.Execute(s)
c(1, 13) = mc(0).submatches(0)
End If
Next c
Range(r(1, 13), r(1, 13)).EntireColumn.AutoFit
End Sub
Thank you for your time :)

Answer 1

Try this:
Sub ExtractUPPERCASE()
Dim re As Object, mc As Object
Dim r As Range, c As Range
Dim s As String
Dim wbdata As Workbook
Dim wsData As Worksheet
Set wbdata = Workbooks("trial1")
Set wsData = wbdata.Worksheets("Final Data")
wsData.Activate
Set r = ActiveSheet.Range("A1", Cells(Rows.Count, "A").End(xlUp))
Set re = CreateObject("vbscript.regexp")
With re
.Global = True
.ignorecase = False
.MultiLine = True
.Pattern = "[A-Z]+\s?[A-Z]+"
End With
For Each c In r
s = c.Text
If re.test(s) = True Then
Set mc = re.Execute(s)
c(1, 13) = mc.Item(0).Value
End If
Next c
Range(r(1, 13), r(1, 13)).EntireColumn.AutoFit
End Sub