I’m having trouble using the correct verbiage but I think it has to do with looping through an array on a userform.

I’ll try to explain the best I know how.... I have a userform and want to be able to past data from elsewhere. After pasting to Textbox1, I want vba to put the corresponding heading in new textbox.

For examples (this would be the copied string which would be the array)

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 have a userform and I want to paste the above string into textbox1 and split into appropriate headings on textboxes 2 to 7 (which are on the same userform) In textbox 2, I want everything between "Clinical:" and "Labs:" (e.g. "history of heart disease" without the headings)

However 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…..

This is my code

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 module that I have been using (from wellsr.com)

    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

I’ve originally been using a code from which I’ve also posted (I hope this is ok) to captures 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 basically adds ALL of the text following the 1st word.

I have a feeling that I'm making this more complicated than it should be.

CodePudding user response：

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

CodePudding user response：

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.

CodePudding user response：

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