Solved: get the ALL CAPITAL words from a cell

As you are talking about 15000 rows, then copy paste below code in module:

Function UpperWords(str As Variant) As String
    Dim i As Integer, sTemp As String, StrTmp As String
    For i = 0 To UBound(Split(str, " "))
        StrTmp = Split(str, " ")(i)
        If UCase(StrTmp) = StrTmp Then sTemp = sTemp & " " & StrTmp
    Next i
    UpperWords = Trim(sTemp)
End Function
Sub ExtractCapitalWords()
Dim Ws As Worksheet
Dim LR As Long
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With
Set Ws = ActiveSheet
LR = Ws.Range("A" & Rows.Count).End(xlUp).Row
Ws.Range("B1:B" & LR).FormulaR1C1 = "=UpperWords(RC1)"
Ws.Range("B1:B" & LR).Value = Ws.Range("B1:B" & LR).Value
Ws.Range("B1").Select
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Open in new window

Assuming your data starts from A1 and you want your result in/from B1, Run ExtractCapitalWords