我正在尝试从Outlook 2016电子邮件正文中提取数据并将其归档到Excel 2016中的某些列。
我可以提取我想要的数据的第一次出现，但是如果它多次出现在电子邮件中，则不会提取数据。
我是VBA的新手，一直在研究此过程的每个阶段，并尝试使代码适合我的需求。我的电子邮件采用以下特定格式：
公司名称：ABC Company
GF名称和编号：普通领班1 xxx-xxx-xxxx
工作人员人数：2
工作电路：领班名称和编号：领班1 xxx-xxx-xxxx
行号：电路123456
线名/点对点
结构：1234至4567
位置地址：大街1234号
州，任何城市
预计时间：上午7点-下午7:30
预计工作日：星期二-星期四领班名称和编号：领班2 xxx-xxx-xxxx
行号：电路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
答案 0 :(得分：0)
您可以将InStr搜索的起点推进到这样的新文本块中。
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