Vba 如何查找和连接文本字符串

我们有一个旧系统，它给我们发送这样的电子邮件

        If InStr(1, vText(i), "Name: ") > 0 Then
            vItem = Split(vText(i), "Name: ")
            x1Sheet.Range("A" & lastrow) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "E-post: ") > 0 Then
            vItem = Split(vText(i), "E-post: ")
            x1Sheet.Range("D" & lastrow) = Trim(vItem(1))
        End If

姓名：姓氏家庭名称

地址：街道

E-post:some@thi.ng

我们使用Outlook宏将信息传输到Excel，如下所示

        If InStr(1, vText(i), "Name: ") > 0 Then
            vItem = Split(vText(i), "Name: ")
            x1Sheet.Range("A" & lastrow) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "E-post: ") > 0 Then
            vItem = Split(vText(i), "E-post: ")
            x1Sheet.Range("D" & lastrow) = Trim(vItem(1))
        End If

然而，这个系统很旧，我们不得不换成另一个系统，发送这样的电子邮件

        If InStr(1, vText(i), "Name: ") > 0 Then
            vItem = Split(vText(i), "Name: ")
            x1Sheet.Range("A" & lastrow) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "E-post: ") > 0 Then
            vItem = Split(vText(i), "E-post: ")
            x1Sheet.Range("D" & lastrow) = Trim(vItem(1))
        End If

客户信息：名字、家庭名称、地址第1行、地址第2行、电子邮箱等等

---

我们仍然需要让“Firstname Familyname”在A列中脱颖而出，让“e-post”在D列中脱颖而出。如何在逗号之间找到文本，并在需要时将它们作为新文本字符串连接起来？

Outlook允许电子邮件具有文本正文、Html正文和/或RTF正文。我从未见过RTF机构，因此我无法对其发表评论。我相信现在大多数电子邮件都只发送Html正文，Outlook然后根据一些简单的规则从Html正文创建文本正文。我之所以这样认为，是因为大多数文本体都遵循相同的简单格式，但有一些文本体看起来非常不同，并且显然是为了在不处理Html的电子邮件包中保持良好的外观而构建的

现有代码必须拆分CRLF上的文本正文，以创建存储在

vText

中的行。然后有一个循环检查

vTest

中的每一行。您显示的代码将在该循环中

您向我们展示了Html主体的显示方式，但这并不能可靠地向我们展示文本主体的外观。请尝试以下代码。如果结果令人满意，我将向您展示如何将其转换为所需的代码

在例程的顶部添加以下语句：

Dim InxPart As Long
Dim LinePart() As String

用以下代码替换现有的检查代码：

If Left$(vText(i), 15) = "Customer info: " Then
  LinePart = Split(Mid$(vText(i), 16), ",")
  Debug.Print LinePart(0)
  Debug.Print LinePart(1)
  Debug.Print LinePart(4)
  Debug.Assert False
  Exit For
End If

如果代码似乎不起任何作用，则表示代码未找到“客户信息：”

如果代码在

Debug.Assert False

语句处停止，您应该在即时窗口中看到类似的内容：

John
Doe
JohnDoe@AcmeProducts.ng

如果你这样做了，那么对我的代码进行一个简单的更改就会产生你想要的效果。如果没有，我们需要更详细地调查您的文本正文

编辑代码以允许调查

InStr

将在字符串中的任何位置找到子字符串

Left$

需要子字符串来启动字符串。可能有一个或多个前导空格。也许嵌入的空间比显示器显示的要多。可能存在非中断空间。与其通过实验来观察效果，不如让我们进行正确的诊断

请将此功能添加到您的模块中

Public Function TidyTextForDspl(ByVal Text As String) As String

  ' Tidy Text for display by replacing white space with visible strings:
  '   Leave single space unchanged
  '   Replace single LF by                 ‹lf›
  '   Replace single CR by                 ‹cr›
  '   Replace single TB by                 ‹tb›
  '   Replace single non-break space by    ‹nbs›
  '   Replace single CRLF by               ‹crlf›
  '   Replace multiple spaces by           ‹n s›       where n is number of repeats
  '   Replace multiple LFs by              ‹n lf›      of white space character
  '   Replace multiple CRs by ‹cr› or      ‹n cr›
  '   Replace multiple TBs by              ‹n tb›
  '   Replace multiple non-break spaces by ‹n nbs›
  '   Replace multiple CRLFs by            ‹n crlf›

  ' 15Mar16  Coded
  '  3Feb19  Replaced "{" (\x7B) and "}" (\x7D) by "‹" (\u2039) and "›" (\u203A)
  '          on the grounds that the angle quotation marks were not likely to
  '          appear in text to be displayed.
  '  5Feb19  Add code to treat CRLF as unit
  ' 28Mar19  Code to calculate PosWsChar after "<x>...<x>" converted to "<n x>"
  '          incorrect if "<x>...<x>" at the start of the string.  Unlikely it
  '          was correct in other situations but this did not matter since the
  '          calculated value would be before the next occurrence of "<x>...<x>".
  '          But, if the string was near the beginning of the string, the
  '          calculated value was negative and the code crashed.

  Dim InsStr As String
  Dim InxWsChar As Long
  Dim NumWsChar As Long
  Dim PosWsChar As Long
  Dim RetnVal As String
  Dim WsCharCrnt As Variant
  Dim WsCharValue As Variant
  Dim WsCharDspl As Variant

  WsCharValue = VBA.Array(" ", vbCr & vbLf, vbLf, vbCr, vbTab, Chr(160))
  WsCharDspl = VBA.Array("s", "crlf", "lf", "cr", "tb", "nbs")

  RetnVal = Text

  ' Replace each whitespace individually
  For InxWsChar = 0 To UBound(WsCharValue)
    RetnVal = Replace(RetnVal, WsCharValue(InxWsChar), "‹" & WsCharDspl(InxWsChar) & "›")
  Next

  ' Look for repeats. If found replace <x> by <n x>
  For InxWsChar = 0 To UBound(WsCharValue)
    'Debug.Assert InxWsChar <> 1
    PosWsChar = 1
    Do While True
      InsStr = "‹" & WsCharDspl(InxWsChar) & "›"
      PosWsChar = InStr(PosWsChar, RetnVal, InsStr & InsStr)
      If PosWsChar = 0 Then
        ' No [more] repeats of this <x>
        Exit Do
      End If
      ' Have <x><x>.  Count number of extra <x>x
      NumWsChar = 2
      Do While Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr), Len(InsStr)) = InsStr
        NumWsChar = NumWsChar + 1
      Loop
      RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & _
                "‹" & NumWsChar & " " & WsCharDspl(InxWsChar) & "›" & _
                Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr))
      PosWsChar = PosWsChar + Len(InsStr) + Len(NumWsChar)

    Loop
  Next

  ' Restore any single spaces
  RetnVal = Replace(RetnVal, "‹" & WsCharDspl(0) & "›", " ")

  TidyTextForDspl = RetnVal

End Function

根据尼顿的评论，如果您包含了更多的代码，这会很有帮助。我已经写了

.Body

，但您可能需要

MyMailItem.Body

或类似的东西

我的语句显示文本正文的前200个字符，每个空格、回车符和换行符都可见，因此我们可以确切地知道其中的内容。我假设“客户信息”行靠近文本正文的开头。如果进一步向下，则需要增加1。我们需要看到的是上面的行和下面的行以及整个“客户信息”行，这样我们就可以知道如何最好地提取行的各个部分

---

请将Debug.Print语句创建的输出添加到您的问题或评论中。

谢谢，我已经认为它可以工作了，但是没有。如果InStr（1，vText（I），“Customer info:”）>0，这仍然可以工作，但是如果保留$（vText（I），15）=“Customer info:”，则此语句找不到任何内容 Then@legotera我在回答中添加了一些诊断代码。请将它添加到您的代码中，然后再报告。很抱歉，耽搁了，我的工作忙得不可开交。我该从哪里开始。。。这是Outlook.MailItem。也许将整个文本放到Excel中的一个单元格中，让vba代码处理拆分更容易些？我不相信电子邮件中的文本正是您所认为的。也许某处有额外的空间。我已经在我的答案中添加了一个全新的例程，您应该将其添加到您的模块中。新的例程将字符串中的所有空格、回车等转换为可见字符，这样就很容易准确地看到字符串包含的内容。我还添加了一个Debug.Print语句，需要您将其添加到例程中。Print语句调用新例程并将其输出写入即时窗口。如果将该输出添加到答案中，将有助于诊断。@legotera分割字符串的VBA代码在Excel VBA和Outlook VBA中是相同的。将整个文本复制到Excel单元格将无济于事。请在我的答案中查找“编辑代码以允许调查”。阅读新文本以更全面地解释我需要你做什么。如果您在问题中包含更多的代码，可能会有所帮助。客户信息是否总是按此顺序排列？