Extract Capitalized Words From String

Hi

I have these strings in Column B:

Benzylpenicillin Panpharma pul.t.inj.+inf.,opl.6 mg/ml intravenøst 100 ml kl 00:00 + 100 ml kl 06:00 + 100 ml kl 12:00 + 100 ml kl 18:00
Digoxin DAK tabletter 62.5 mikg peroralt1 tablet 1 gang(e) Daglig
Furix tabletter 40 mg peroralt2 tabletter til morgen + 1 tabletter til middag
Unikalk SIlver tabletter peroralt1 tablet til morgen og til aften
Ciprofloxacin Fresenius Kabi inf.væske, opløsning 2 mg/ml intravenøst 200 ml kl 08:00 + 200 ml kl 20:00

I'd like to extract all the Capitalized words in the above strings into Column A such that Column A will reflect this:

Benzylpenicillin Panpharma
Digoxin DAK
Furix
Unikalk SIlver
Ciprofloxacin Fresenius Kabi

I've searched the Web and haven't found any references to this kind of extraction. You're help will be greatly appreciated.

John

Digoxin DAK tabletter 62.5 mikg peroralt1 tablet 1 gang(e) Daglig does not fit a pattern
as Daglig is also upper case

Hi martindwilson

Ha! I missed that. Been looking at it too long. Well, that aside, can it be done

extract all the Capitalized words

I'll deal with the anomalies if I can get a solution to the issue.

John

Hello John,

Here is the solution. I ran it against the data the posted and the results match. Give a try on a copy of the actual data and let me know what happens.

Sub ExtractCapWordsOnly()

  Dim C As Long
  Dim R As Long
  Dim RegExp As Object
  Dim Rng As Range
  Dim RngEnd As Range
  Dim S As String
  Dim T As Variant
  Dim Text As String
    
    Set Rng = Range("B1")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Range(Rng, RngEnd))
    C = Rng.Column
    
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = False
    RegExp.Pattern = "([A-Z]\w+)"
    
      For R = Rng.Row To Rng.Rows.Count + Rng.Row - 1
        S = Cells(R, C).Text
        If RegExp.Test(S) Then
          Set Matches = RegExp.Execute(S)
            For I = 0 To Matches.Count - 1
              Text = Text & Matches(I) & " "
            Next I
          Cells(R, C - 1) = Trim(Text)
          Text = ""
        End If
      Next R
      
   Set RegExp = Nothing
   
End Sub

Hi Leith

As always, your code gives me exactly what I was looking for. I had to add these Dim statements

Dim Matches As Variant 
Dim I As Long

You amaze me in your ability to find solutions to our "troubles". Thanks for your help.

John

Hello FN2010,

Regular Expressions can parse almost any type of text. I would need to see before and after samples of what you want. The more the better. You should start a new thread since this one has been marked solved.