excel - 将重复的数据字符串从 Outlook 提取到 Excel

Question

我正在尝试从 Outlook 2016 电子邮件正文中提取数据并归档到 Excel 2016 中的某些列。

我可以提取我想要的数据的第一次出现，但如果它在电子邮件中出现多次，则不会提取数据。

我是 VBA 的新手，一直在研究这个过程的每个阶段，并试图使代码符合我的需求。我的电子邮件采用特定格式，如下所示：

公司名称：ABC 公司
GF 名称和编号：General Foreman 1 xxx-xxx-xxxx
工作人员人数：2
正在工作的电路：

工头姓名和编号：工头 1 xxx-xxx-xxxx
线路编号：电路 123456
线路名称/点对点
结构：1234 至 4567
位置地址：1234 Main Street
任何城市，州
预计时间：上午 7 点 - 晚上 7:30
预计工作日期：周二 - 周四

工头姓名和编号：工头 2 xxx-xxx-xxxx
线路编号：Circuit 987654
线路名称/点对点
结构：987 到 456
位置地址：9876 Main Street
任何城市，州
预计时间：上午 7 点 - 晚上 7:30
预计工作日期：周三 - 周四

我在 Excel 中的预期输出包含以下列：行号、工头、总工头、船员位置地址和收到电子邮件的时间。

请在下面查看我的代码：

Sub ValidateCrewLocations()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim firstterm As String
Dim secondterm As String
Dim startpos As Long
Dim stoppos As Long
Dim nextposition As Long
Dim strPublicFolder As String
Dim colFolders
Dim howManyInRange As Long
Dim foundCount As Long
Dim oFindRange As Range
Dim rngSearch As Range
Dim srchVal As String

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Crew Notifications")


nextposition = 1
i = 1

rCount = rCount + 1

Worksheets("Sheet1").Range("A6:E250").ClearContents

For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_Date").Value Then
srchVal = "Foreman Name and Number: "
strBody = OutlookMail.Body
howManyInRange = UBound(Split(strBody, srchVal))
Do
foundCount = foundCount + 1
strFind = "Line Number: "
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColA = Left(strColA, InStr(strColA, vbLf) - 1)
strFind = "Foreman Name and Number: "
strColB = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColB = Left(strColB, InStr(strColB, vbLf) - 15)
strFind = "GF Name and Number: "
strColC = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColC = Left(strColC, InStr(strColC, vbLf) - 15)
firstterm = "Location Address: "
secondterm = "Estimated Time:"
startpos = InStr(1, strBody, firstterm, vbTextCompare)
stoppos = InStr(startpos, strBody, secondterm, vbTextCompare)
strColD = Mid(strBody, startpos + Len(firstterm), stoppos - startpos - 
Len(secondterm) - 6)
strColE = OutlookMail.ReceivedTime
Range("Job_Name").Offset(i, 0).Value = strColA
Range("Foreman").Offset(i, 0).Value = strColB
Range("General_Foreman").Offset(i, 0).Value = strColC
Range("Location_Address").Offset(i, 0).Value = strColD
Range("Email_Received_Time").Offset(i, 0).Value = strColE

i = i + 1

Loop While Not foundCount >= howManyInRange
End If

Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

Dim c As Range
For Each c In ActiveSheet.UsedRange
With c
    .Value = WorksheetFunction.Trim(.Value)
End With
Next c
Application.OnTime Now + TimeValue("00:15:00"), "ValidateCrewLocations"

End Sub

标签： excelvbaoutlook

Answer 1

You could advance the starting point of the InStr search to new text blocks like this.

Option Explicit

Sub ValidateCrewLocations()

Dim OutlookApp As outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder

Dim OutlookMail As Variant

Dim strBody As String
Dim strFind As String

Dim strColA As String
Dim strColB As String
Dim strColC As String
Dim strColD As String
Dim strColE As String

Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim firstterm As String
Dim secondterm As String
Dim startpos As Long
Dim stoppos As Long

Dim strPublicFolder As String
Dim colFolders
Dim howManyInRange As Long
Dim foundCount As Long
Dim oFindRange As Range
Dim rngSearch As Range
Dim srchVal As String

Dim fbStart As Long

Set OutlookApp = New outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Crew Notifications")

'rCount = rCount + 1

'Worksheets("Sheet1").Range("A6:E250").ClearContents

For Each OutlookMail In Folder.Items

    'If OutlookMail.ReceivedTime >= Range("From_Date").Value Then

        strBody = OutlookMail.body
        srchVal = "Foreman Name and Number: "

        fbStart = 0

        howManyInRange = UBound(Split(strBody, srchVal))

        For i = 1 To howManyInRange

            strFind = "GF Name and Number: "
            strColC = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))

            strColC = Left(strColC, InStr(strColC, vbLf) - 15)
            Debug.Print strColC

            strFind = "Foreman Name and Number: "

            'Foreman block start + 1
            ' On first instance of InStr the search starts at position 1
            ' On second and subsequent use of InStr,
            '  adding one to fbStart begins the search
            '  for the next Foreman block starting position
            '  one position past the beginning of the previous
            '  Foreman block starting position.
            fbStart = InStr(fbStart + 1, strBody, strFind, 1)
            Debug.Print i & " Foreman block start: " & fbStart

            strColB = Mid(strBody, InStr(fbStart, strBody, strFind, 1) + Len(strFind))
            'Debug.Print strColB

            strColB = Left(strColB, InStr(strColB, vbLf) - 15)
            Debug.Print strColB

            strFind = "Line Number: "

            strColA = Mid(strBody, InStr(fbStart, strBody, strFind, 1) + Len(strFind))
            'Debug.Print strColA

            strColA = Left(strColA, InStr(strColA, vbLf) - 1)
            Debug.Print strColA

            firstterm = "Location Address: "
            secondterm = "Estimated Time:"

            startpos = InStr(fbStart, strBody, firstterm, vbTextCompare)
            Debug.Print startpos

            stoppos = InStr(startpos, strBody, secondterm, vbTextCompare)
            Debug.Print stoppos

            strColD = Mid(strBody, startpos + Len(firstterm), stoppos - startpos - Len(secondterm) - 6)
            Debug.Print strColD

            strColE = OutlookMail.ReceivedTime
            Debug.Print strColE

            'Range("Job_Name").Offset(i, 0).Value = strColA
            'Range("Foreman").Offset(i, 0).Value = strColB
            'Range("General_Foreman").Offset(i, 0).Value = strColC
            'Range("Location_Address").Offset(i, 0).Value = strColD
            'Range("Email_Received_Time").Offset(i, 0).Value = strColE

        Next

    'End If

Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

'Dim c As Range
'For Each c In ActiveSheet.UsedRange
'With c
'    .Value = WorksheetFunction.Trim(.Value)
'End With
'Next c
'Application.OnTime Now + TimeValue("00:15:00"), "ValidateCrewLocations"

End Sub