Looping through array and capturing substring between two specific words - arrays

Question

I paste data from elsewhere to a userform.
For example (the copied string)
Clinical: history of heart disease
Labs: elevated cholesterol on 8Aug
Meds: just started cholesterol medication
Supplements: none
Allergies: none
Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting
I want to paste the above string into textbox1.
The string should then be split into appropriate headings on textboxes 2 to 7 on the same userform.
In textbox 2, I want everything between "Clinical:" and "Labs:"
"history of heart disease" without the headings.
If “Labs:” is not present, I want everything between Clinical: and Meds (or next heading)
At this point, I think a loop to repeat this process but for the next items
(e.g. texbox 3 = everything between Labs: and Meds – or next heading; Textbox4 = everything between Meds: and Supplements) – or next heading; etc.
Private Sub CommandButton1_Click()
Dim strnames(1 To 6) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim check As Integer
str1 = TextBox1
x = 1
For box = 1 To 6
If InStr(TextBox1.Text, strnames(1)) > 0 Then
str2 = SuperMid(str1, strnames(x), strnames(x + 1))
TextBox2 = str2
End If
If InStr(TextBox1.Text, strnames(1)) = 0 Then
TextBox2 = "none"
End If
Next box
End sub
This is the code that I have been using (from wellsr.com) to capture the data between word1 and word2 of the array. The problem occurs when a word in the array is not present at which point it adds all of the text following the first word.
Public Function SuperMid(ByVal strMain As String, str1 As String, str2 As String,
Optional reverse As Boolean) As String
Dim i As Integer, j As Integer, temp As Variant
On Error GoTo errhandler:
If reverse = True Then
i = InStrRev(strMain, str1)
j = InStrRev(strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStrRev(strMain, str2, i)
If i = j Then 'try to search 2nd half of string for unique match
j = InStrRev(strMain, str2, i - 1)
End If
End If
If reverse = False Then
i = InStr(1, strMain, str1)
j = InStr(1, strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStr(i + Len(str1), strMain, str2)
If i = j Then 'try to search 2nd half of string for unique match
j = InStr(i + 1, strMain, str2)
End If
End If
If i = 0 And j = 0 Then GoTo errhandler:
If j = 0 Then j = Len(strMain) + Len(str2) 'just to make it arbitrarily large
If i = 0 Then i = Len(strMain) + Len(str1) 'just to make it arbitrarily large
If i > j And j <> 0 Then 'swap order
temp = j
j = i
i = temp
temp = str2
str2 = str1
str1 = temp
End If
i = i + Len(str1)
SuperMid = Mid(strMain, i, j - i)
Exit Function
errhandler:
MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
End
End Function

Answer 1

Sometimes you need to add a little complication to make things easier. The code below may be of interest.
Option Explicit
' This code requires a reference to the Microsoft Scripting Runtime
Public Sub Test()
Dim myHistory As Scripting.Dictionary
Set myHistory = GetHistoryDictionary("Clinical: history of heart disease Labs: elevated cholesterol on 8AugMeds: just started cholesterol medication Supplements: none Allergies: none Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting)")
Debug.Print VBA.Join(myHistory.keys, vbCrLf)
Debug.Print VBA.Join(myHistory.Items, vbCrLf)
Debug.Print
If myHistory.Exists("Labs") Then
Debug.Print "The Lab report was: " & myHistory.Item("Labs")
End If
Debug.Print
If myHistory.Exists("Heamatology") Then
Debug.Print "The Heamatolofy report was: " & myHistory.Item("Heamatology")
Else
Debug.Print "The Heamtology report was: " & "Not Present"
End If
End Sub
Public Function GetHistoryDictionary(ByVal ipString As String) As Scripting.Dictionary
' Create an array of the labes in the input strings
Static myLabels As Variant
If VBA.IsEmpty(myLabels) Then
myLabels = Split("Clinical:,Labs:,Meds:,Supps:,Allergies:,Activity:,NFPE:", ",")
End If
' Add a character we can use as a separator with SPlit
Dim myLabel As Variant
For Each myLabel In myLabels
ipString = VBA.Replace(ipString, myLabel, "#" & myLabel)
Next
' remove characters until we have removed the first separator character
Do Until VBA.Left(ipString, 1) = "#"
ipString = VBA.Mid$(ipString, 2)
Loop
ipString = VBA.Mid$(ipString, 2)
'Get an array of Label/Message
Dim myItems As Variant
myItems = VBA.Split(ipString, "#")
'Split the label/message and put into a scripting.dictionary
Dim myHistory As Scripting.Dictionary
Set myHistory = New Scripting.Dictionary
Dim myItem As Variant
For Each myItem In myItems
Dim mySPlit As Variant
mySPlit = VBA.Split(myItem, ":")
myHistory.Add mySPlit(0), mySPlit(1)
Next
Set GetHistoryDictionary = myHistory
End Function

Answer 2

Building on your code:
First ensure you have Option Explicit at the top of all your modules as this will help pick out any simple errors.
In your UserForm you could have text boxes labeled TextBox1, TextBox2 etc. Then you could use this for the command button code:
Private Sub CommandButton1_Click()
Dim strnames(1 To 7) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim str1 As String
str1 = TextBox1.Text
' It makes the code clearer if you are explicit about what you want
' from your text box - .Text (or .Value), even if VBA will
' give you its value if you don't specify it.
Dim str2 As String
Dim ctlControl As Control
Dim lngTextBoxNumber As Long
' You need to loop through all the controls on the form, and then
' determine which are the ones you want to alter. This assumes each
' textbox you are interested in is named in the form
' TextBox1, TextBox2 etc. To make code maintenance easier, I would
' probably put this kind of identification information on the
' controls' tag properties - that way if you rename the controls or
' you add a text box which is for something else, you won't break
' the code. You would then be reading this information off the
' .Tag property rather than .Name.
For Each ctlControl In Me.Controls
If Mid$(ctlControl.Name, 1, 7) = "TextBox" Then
lngTextBoxNumber = CLng(Mid$(ctlControl.Name, 8))
If lngTextBoxNumber > 1 And lngTextBoxNumber < UBound(strnames) Then
str2 = SuperMid(str1, strnames(lngTextBoxNumber), strnames(lngTextBoxNumber + 1))
If str2 = vbNullString Then
str2 = "none"
End If
ctlControl.Text = str2
End If
End If
Next ctlControl
End Sub
SuperMid seems to be quite an unforgiving function - as you have it, if it can't find the text before and after the text you are looking for, it will fail with an error: it might be better for it to return an empty string - otherwise your code will fail not all the strnames are present in your original string.
I altered the end of that function to look like this:
Exit Function
errhandler:
'MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
SuperMid = vbNullString
End Function
As it stands, your code would fail to pick up some of the information if items are left out, or had been entered in a different order: see freeflow's answer to avoid this.

Answer 3

I would skip the array because what you're really looking to do is to extract the phrase following the keyword. The example below shows how you can use a function to isolate the phrase.
Function ExtractByKeyword(ByVal source As String, _
ByVal keyword As String) As String
'--- extracts a phrase (substring) from the given source,
' beginning with the keyword and ending with the next
' (unknown) keyword.
' Keywords are delimited by a preceding space ' ' and
' followed by a colon ":" or EOL
Dim pos1 As Long
pos1 = InStr(1, source, keyword, vbTextCompare)
If pos1 = 0 Then
'--- the keyword was not found, so return a null string
ExtractByKeyword = vbNullString
Exit Function
End If
Dim phrase As String
'--- skip over the keyword and find the next keyword
' (i.e. look for the next colon)
Dim pos2 As Long
pos2 = InStr(pos1 + Len(keyword) + 1, source, ":", vbTextCompare)
If pos2 = 0 Then
'--- this is the last keyword and phrase in the source
phrase = Right$(source, Len(source) - pos1 - Len(keyword) - 1)
Else
'--- now work backwards from the second keyword to find the
' end of the phrase (which is the space just before the
' second keyword
Dim pos3 As Long
pos3 = InStrRev(source, " ", pos2, vbTextCompare)
Dim startsAt As Long
Dim phraseLen As Long
startsAt = pos1 + Len(keyword) + 2
phraseLen = pos3 - startsAt
phrase = Mid$(source, startsAt, phraseLen)
End If
ExtractByKeyword = phrase
End Function
I used the test routine below to check the extraction:
Option Explicit
Sub test()
Const medInfo As String = "Clinical: history of heart disease" & _
" Labs: elevated cholesterol on 8Aug" & _
" Meds: just started cholesterol medication" & _
" Supplements: none" & _
" Allergies: none" & _
" Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting"
Dim phrase As String
phrase = ExtractByKeyword(medInfo, "Labs")
If phrase <> vbNullString Then
Debug.Print " Labs -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Clinical")
If phrase <> vbNullString Then
Debug.Print " Clinical -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Activity")
If phrase <> vbNullString Then
Debug.Print " Activity -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Meds")
If phrase <> vbNullString Then
Debug.Print " Meds -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Allergies")
If phrase <> vbNullString Then
Debug.Print "Allergies -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
End Sub