从Outlook电子邮件中提取数据到excel

我每天有200封电子邮件，语法如下：

Hi, These are our clients. 548628797 FV THD EHSI 34215564824 JUAN CARLOS CORENDA ALVARES 1 31,43 243234133 FV THD EHSI 752520934982 JUAN CARLOS CORENDA ALVARES 2 2,8 2340291438 RFR WER IRJF 323442342312 CARLITO HIMAT 3,00 324 EHTF TGS HKTY 32423 WILLIAM TARING 1,2 Thank you! 

1. 我是否提取“这些是我们的客户”之间的界限 和“谢谢你！” ？ 一些电子邮件只有1行，其他电子邮件有20或更多。 或者更好地从第4行提取到第1个结尾？

2. 在Excel中，如果我粘贴的行名称将被分隔在不同的单元格。 我努力了：

    =IF(COUNT(FIND({0,1,2,3,4,5,6,7,8,9},J2))>0, K2&" "&L2&" "&M2&" "&N2, "NO NUMBERS IN J2") 

   但是，如何才能停止连接的名称，直到它与金额的单元格？

3. 数量，当粘贴在Excel中将忽略分隔符“，”只是给我，而不是3143数额，我必须粘贴文本，以正确的金额。 但是，如果我粘贴文本，那么整行将被插入一个单元格不在不同的单元格。

我有一个以前的代码从电子邮件中提取表格数据，但是我没有看到如何将代码实现到我目前的问题 – 首先，因为我不知道如何看待提取。 在excel中提取正文，用""replace前三行和最后一行，然后按行或列分割行。

从我发现到现在的线路布局是：

• 1至13个字符
• 1空间
• 2到4个字符
• 如果前面有2个字符然后4个空格/如果3个字符然后3个空格/如果4个字符然后2个空格
• 总是4个字符
• 1到11个空格
• 1至15个字符
• 1到5个空格
• 名称最多可以有7个名字（西class牙名字），最后可以有数字
• 1到20个空格
• 金额可以是1,00或1，可以是000000000001,15（有些错误，他们不能纠正）

当前代码：

 Sub exporttheirclients() Const FOLDER_PATH = "\\Mailbox - ME\Their clients" Dim olkMsg As Object, _ olkFld As Object, _ excApp As Object, _ excWkb As Object, _ excWks As Object, _ intRow As Integer, _ intCnt As Integer, _ data_email As String, _ strFilename As String, _ arrCells As Variant, _ varb As Variant, varD As Variant, varF As Variant Dim sinceDt, toDt As Date sinceDt = InputBox("STARTING PERIOD") toDt = InputBox("ENDING PERIOD") strFilename = "C:\THEIR CLIENTS\xlsx\TCLIENTS" If strFilename <> "" Then Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add() Set excWks = excWkb.ActiveSheet excApp.DisplayAlerts = False With excWks .Cells(1, 1) = "SUBJECT" .Cells(1, 2) = "DATE" .Cells(1, 3) = "REF NR" .Cells(1, 4) = "AMOUNT" .Cells(1, 5) = "CITY" End With intRow = 2 Set olkFld = OpenOutlookFolder(FOLDER_PATH) For Each olkMsg In olkFld.Items data_email = olkMsg.ReceivedTime If olkMsg.Class = olMail Then If data_email >= sinceDt And data_email <= toDt + 1 Then arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255)) For intCnt = LBound(arrCells) To UBound(arrCells) Step 16 On Error GoTo Handler varb = arrCells(intCnt + 1) varD = arrCells(intCnt + 3) varF = arrCells(intCnt + 5) excWks.Cells(intRow, 1) = olkMsg.Subject excWks.Cells(intRow, 2) = Left(olkMsg.ReceivedTime, 10) excWks.Cells(intRow, 3) = varb excWks.Cells(intRow, 4) = varD excWks.Cells(intRow, 5) = Left(varF, 4) intRow = intRow + 1 Next End If End If Label1: Next Set olkMsg = Nothing excWkb.SaveAs strFilename, 52 excWkb.Close End If Set olkFld = Nothing Set excWks = Nothing Set excWkb = Nothing Set excApp = Nothing MsgBox "Ta dam! They have been exported ", vbInformation + vbOKOnly Call opexl Exit Sub Handler: Dim myOutlookFolders As Outlook.Folder Dim myDestFolder As Outlook.Folder Set myOutlookFolders = Session.GetDefaultFolder(olFolderInbox) Set myDestFolder = Session.Folders("Mailbox - ME").Folders("Their clients").Folders("Manually input") If olkMsg <> "Nothing" Then olkMsg.Move myDestFolder MsgBox "An email has been found with a problem. The search continues..." Else: End End If Resume Label1: End Sub