Vba 从电子邮件中获取部分主题，并将其输入excel表格

您好，下面我已经包括了当前的vba脚本，用于在包含多封电子邮件的文件中运行，这些电子邮件具有与电子邮件中讨论的地址更改相对应的特定文件名。我想从每个文件名中提取与地址更改相关的文本，并在excel表格中输入新地址和旧地址。此文件夹中的所有电子邮件的标题格式分为4类。以下是所有四种邮件的示例：

地址变更-皇后大道14至12号 地址变更循环-从国王街4号到2号 地址变更-南街40号至主大道1号 地址变更循环-从4门街到2第10街。 正如您所看到的，它们都是以相同的字符串地址更改循环开始的，但是我很难获得一个能够适应所有这些不同场景的脚本。下面我已经包括了脚本的当前迭代，如果任何人有任何建议或改进，这将是非常有用的，谢谢你

Dim StrFile As String
'Change this to the directory containing all Address Change Circulation emails
'This will Pull in a list and, to the best of its ability make two columns that hold the data for
'the old and the new address
StrFile = Dir(Range("AddressChangeFolderPath").Value)
Dim Names() As String
Dim StrName
Do While Len(StrFile) > 0
    CheckVal = InStr(1, StrFile, "Address Change Circulation -", vbTextCompare) + _
        InStr(1, StrFile, "Address Change Circulation from ", vbTextCompare)
    If CheckVal <> 1 Then   'if the email does not fit the standard, just place it in the cell and
                            'move on to the next entry
        Selection.Value = StrFile
        Selection.Interior.Color = RGB(255, 255, 0) 'highlight the cell
        Selection.Offset(1, 0).Select
    Else
        StrName = Right(StrFile, Len(StrFile) - 29) 'trim to the correct size - probably not the
                                                    'best way to do this but it works
        If Left(StrName, 4) = "from" Then
            StrName = Right(StrName, Len(StrName) - 5)
        ElseIf Left(StrName, 2) = "om" Then
 StrName = Right(StrName, Len(StrName) - 3)
        End If
        StrName = Left(StrName, Len(StrName) - 4)
        Changes = Split(StrName, " and ")
        For Each Change In Changes
            Names = Split(Change, " to ")

            If Len(Names(0)) < 5 Then
                Selection.Value = Names(0) & Right(Names(1), Len(Names(1)) - Len(Names(0)))
            Else
                Selection.Value = Names(0)
            End If
            If UBound(Names) >= 1 Then 'this is a zero indexed array, checking greater than or
                                       'equal to 1 will check if there are two or more entries
                Selection.Offset(0, 1).Value = Names(1) ' in the event that there is no " to " in
                                                'the file name and it hasn't been handeled already
            End If
            Selection.Offset(1, 0).Select 'select the next cell to accept the next entry
        Next
    End If

loop

---

根据您的示例，这可能是一种合理的方法。 如果将解析拆分为一个单独的方法，则更容易管理

仅解析工作表上某个范围内的文本：

Sub Process()
    Dim c As Range, op As String, np As String

    For Each c In Range("A1:A6").Cells
        ParseAddresses c.Value, op, np '<< passing np/op by reference...
        c.Offset(0, 1).Value = op
        c.Offset(0, 2).Value = np
    Next c

End Sub

'Parse two addresses from "t" into "op" and "np"
Sub ParseAddresses(ByVal t, ByRef op As String, ByRef np As String)
    Dim arr

    op = "": np = ""
    t = Trim(t)
    If t Like "Address Change Circulation -*to*" Then
        t = Replace(t, "Address Change Circulation -", "")
        t = Replace(t, "from", "")
        arr = Split(t, "to")
        op = Trim(arr(0))
        np = Trim(arr(1))
        ' "from" part is just a number: replace number in "to" part
        If IsNumeric(op) Then
            arr = Split(np, " ")
            arr(0) = op
            op = Join(arr, " ")
        End If
    End If
End Sub

---

你的问题到底是什么？很难回答，因为我不知道你想问什么。脚本当前是否工作？你面临什么问题？是的，脚本目前适用于我列出的前两个案例，但不适用于最后两个案例。我面临的问题是如何解释最后两种情况，脚本目前解释了另外两种情况。另一个问题是，我想知道是否有更好的方法或函数来解析来自文件名的数据？当前的方法主要是包含在while循环中的大量if语句。如果有另一种方法不依赖于文件名是统一的，并且使用right或left函数，那么我愿意使用它。