Сканирование электронной почты и извлечение определенных строк в Excel - PullRequest
Новая
       8

Сканирование электронной почты и извлечение определенных строк в Excel

0 голосов
/ 28 января 2019

Мне нужно настроить Excel, который сканирует электронные письма в папке Outlook (например, «Тест»).Письма генерируются автоматически и содержат предполагаемую таблицу, которая на самом деле представляет собой просто текст, разделенный пробелами.

Количество записей отличается в каждом письме.

пример:

enter image description here

Код VBA, извлекающий только одинСтрока информации работает, но я не могу найти работающий метод для цикла, который правильно сканирует оставшееся тело письма. 

Sub EmailExtract ()


Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namesapce
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColX, strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim sFilterStart As String
Dim sFilterEnd As String
Dim sExtract As String
Dim aExtract () As String
Dim aExtractItems () As String


Set OutloopApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder =         
OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("TEST")


i = 1 


On Error Resume Next
rCount = xlSheet.Range("A" & xlSheetl.Rows.Count).End(-4162).Row
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 


strFind"368"
strColx = Mid(strBody, InStr(1, strBody, strFind, 1))
strColx = Left(strColx, 66)


stColA = Left(strColx, 8)
strColA = LTrim(strColA)
strColA = RTrim(strColA)


stColB = Left(strColx, 10, 10)
strColB = LTrim(strColB)
strColB = RTrim(strColB)


stColC = Left(strColx, 20, 20)
strColC = LTrim(strColC)
strColC = RTrim(strColC)


stColD = Left(strColx, 45, 10)
strColD = LTrim(strColD)
strColD = RTrim(strColD)


stColE = Left(strColx, 56, 11)
strColE = LTrim(strColE)
strColE = RTrim(strColE)


strFind = "Ship to"
strColF = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColF = Left(strColF, InStr(strColF, vbLf) -1)


Range("Release").Offset(i, 0).Value = stColA
Range("Schedule").Offset(i, 0).Value = stColB
Range("Part_Number").Offset(i, 0).Value = stColC
Range("Quantity").Offset(i, 0).Value = stColD
Range("First_req_Date").Offset(i, 0).Value = stColE
Range("Ship_To").Offset(i, 0).Value = stColF


i = i + 1
End If


Next OutlookMail


Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing


End Sub

Полученная таблица выглядит следующим образом:

enter image description here

Отображение всех записей всех электронных писем в одном списке.

Я ищу решение, которое сканирует одно письмо за другим, извлекая все строки.

Надеюсь, у вас есть вся необходимая информация, я впервые публикую что-нибудь ...

Спасибо за вашу помощь!

каспар

...