我在使用正確的措辭時遇到了麻煩，但我認為這與遍歷用戶表單上的陣列有關。
我會盡力解釋我所知道的最好的方法......我有一個用戶表單，并且希望能夠從其他地方獲取過去的資料。粘貼到 Textbox1 后，我希望 vba 將相應的標題放在新的文本框中。
例如（這將是復制的字串，即陣列）
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
我有一個用戶表單，我想將上面的字串粘貼到 textbox1 并拆分為文本框 2 到 7 上的適當標題（它們在同一個用戶表單上） 在文本框 2 中，我想要“臨床：”和“實驗室：”之間的所有內容：（例如沒有標題的“心臟病史”）
但是，如果“實驗室：”不存在，我想要臨床：和藥物（或下一個標題）之間的所有內容
在這一點上，我想一個回圈來重復這個程序，但對于下一個專案（例如 texbox 3 = Labs: 和 Meds 之間的所有內容 - 或下一個標題；Textbox4 = Meds: 和 Supplements 之間的所有內容） - 或下一個標題；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 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
我最初一直在使用我也發布過的代碼（我希望這沒問題）來捕獲陣列的 word1 和 word2 之間的資料。當陣列中的單詞不存在時，就會出現問題，此時它基本上會在第一個單詞之后添加所有文本。
我有一種感覺，我讓這變得比它應該的更復雜。
uj5u.com熱心網友回復：
有時您需要添加一些復雜性以使事情變得更容易。下面的代碼可能很有趣。
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
uj5u.com熱心網友回復：
以您的代碼為基礎：
首先確保你Option Explicit在所有模塊的頂部，因為這將有助于找出任何簡單的錯誤。
在您的用戶表單中，您可以有標記為 TextBox1、TextBox2 等的文本框。然后您可以將其用于命令按鈕代碼：
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 似乎是一個非常無情的功能 - 正如您所擁有的那樣，如果它在您要查找的文本之前和之后找不到文本，它將失敗并出現錯誤：它可能會更好地回傳一個空字串- 否則您的代碼將失敗，并非所有 strnames 都存在于您的原始字串中。
我將該函式的末尾更改為如下所示：
Exit Function
errhandler:
'MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
SuperMid = vbNullString
End Function
就目前而言，如果專案被遺漏或以不同的順序輸入，您的代碼將無法獲取某些資訊：請參閱 freeflow 的答案以避免這種情況。
uj5u.com熱心網友回復：
我會跳過陣列，因為您真正想要做的是提取關鍵字后面的短語。下面的示例顯示了如何使用函式來隔離短語。
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
我使用下面的測驗程式來檢查提取：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/516485.html
上一篇：根據格式從字串中獲取值