每次电子邮件结构略有变化时,将outlook电子邮件的特定内容导出到Excel
我们有一份实习申请表(通过formsite.com),由未来的实习生填写并提交。所有提交的文件均以表格形式在MS Excel中接收。但是,有些学位/专业我们在表格中还有其他问题,因此收到的电子邮件结构保持不变,但表格中的行数可能不同(根据申请人必须回答的问题数量) 由于有数千个这样的应用程序,我一直在尝试将这些内容导出到Excel的代码。我在Excel中尝试了以下代码,但需要找出如何针对不同的行数进行调整-如果输入最大行数,则不会导入行数较少的电子邮件:每次电子邮件结构略有变化时,将outlook电子邮件的特定内容导出到Excel,excel,vba,email,outlook,Excel,Vba,Email,Outlook,我们有一份实习申请表(通过formsite.com),由未来的实习生填写并提交。所有提交的文件均以表格形式在MS Excel中接收。但是,有些学位/专业我们在表格中还有其他问题,因此收到的电子邮件结构保持不变,但表格中的行数可能不同(根据申请人必须回答的问题数量) 由于有数千个这样的应用程序,我一直在尝试将这些内容导出到Excel的代码。我在Excel中尝试了以下代码,但需要找出如何针对不同的行数进行调整-如果输入最大行数,则不会导入行数较少的电子邮件: Sub ParseEmailFolder
Sub ParseEmailFolderToExcel()
Set objApp = Application
Dim olns As Outlook.Namespace
Set olns = Outlook.GetNamespace("MAPI")
Set myinbox = olns.PickFolder
Dim XLApp As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim EachElement()
Dim myRecipient As Outlook.Recipient
Dim ExcelWasNotRunning As Boolean
On Error Resume Next
Set XLApp = GetObject(, "Excel.Application")
If Err Then
ExcelWasNotRunning = True
Set XLApp = New Excel.Application
XLApp.Visible = True
End If
On Error GoTo 0
Set wkb = XLApp.Workbooks.Add
Set wks = wkb.Sheets(1)
With wks
StartCount = 1 'how many emails (start at 1 to leave row one for headers)
strEmailContents = ""
For Each outlookmessage In myinbox.Items
StartCount = StartCount + 1 'increment email count
Set myRecipient = olns.CreateRecipient(Right(outlookmessage.SenderEmailAddress, 5))
myRecipient.Resolve
If myRecipient.Resolved Then
Debug.Print myRecipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress
End If
UseCol = 1 'E; previous columns hold the email header information shown above (sender, date, etc)
FullMsg = outlookmessage.Body
AllLines = Split(FullMsg, vbCrLf)
For FullLine = LBound(AllLines) To UBound(AllLines)
On Error Resume Next
'Here is where you could decide to process only certain lines, using maybe a select case statement
eachVal = Split(AllLines(FullLine), ":") 'for a comma delimited file
For EachDataPoint = LBound(eachVal) To UBound(eachVal) 'load each value to an array
UseCol = UseCol + 1
ReDim Preserve EachElement(UseCol)
'.cells(row,column)
EachElement(UseCol - 1) = eachVal(EachDataPoint)
'.Cells(StartCount, UseCol - 1).Value = eachVal(EachDataPoint)
Next
Next
On Error GoTo 0
'Now place just the selected data into the output workbook- from the array. Not necessary if you process lines individually and paste their data directly into Excel as you go
wks.Cells(StartCount, 1) = EachElement(1)
wks.Cells(StartCount, 2) = EachElement(2)
wks.Cells(StartCount, 3) = EachElement(3)
wks.Cells(StartCount, 4) = EachElement(4)
wks.Cells(StartCount, 5) = EachElement(5)
wks.Cells(StartCount, 6) = EachElement(6)
wks.Cells(StartCount, 7) = EachElement(7)
wks.Cells(StartCount, 8) = EachElement(8)
wks.Cells(StartCount, 9) = EachElement(9)
wks.Cells(StartCount, 10) = EachElement(10)
wks.Cells(StartCount, 11) = EachElement(11)
wks.Cells(StartCount, 12) = EachElement(12)
wks.Cells(StartCount, 13) = EachElement(13)
wks.Cells(StartCount, 14) = EachElement(14)
wks.Cells(StartCount, 15) = EachElement(15)
wks.Cells(StartCount, 16) = EachElement(16)
wks.Cells(StartCount, 17) = EachElement(17)
wks.Cells(StartCount, 18) = EachElement(18)
wks.Cells(StartCount, 19) = EachElement(19)
wks.Cells(StartCount, 20) = EachElement(20)
wks.Cells(StartCount, 21) = EachElement(21)
wks.Cells(StartCount, 22) = EachElement(22)
wks.Cells(StartCount, 23) = EachElement(23)
wks.Cells(StartCount, 24) = EachElement(24)
wks.Cells(StartCount, 25) = EachElement(25)
wks.Cells(StartCount, 26) = EachElement(26)
wks.Cells(StartCount, 27) = EachElement(27)
wks.Cells(StartCount, 28) = EachElement(28)
wks.Cells(StartCount, 29) = EachElement(29)
wks.Cells(StartCount, 30) = EachElement(30)
wks.Cells(StartCount, 31) = EachElement(31)
wks.Cells(StartCount, 32) = EachElement(32)
wks.Cells(StartCount, 33) = EachElement(33)
wks.Cells(StartCount, 34) = EachElement(34)
wks.Cells(StartCount, 35) = EachElement(35)
wks.Cells(StartCount, 36) = EachElement(36)
wks.Cells(StartCount, 37) = EachElement(37)
wks.Cells(StartCount, 38) = EachElement(38)
wks.Cells(StartCount, 39) = EachElement(39)
wks.Cells(StartCount, 40) = EachElement(40)
wks.Cells(StartCount, 41) = EachElement(41)
Next
End With
UseRow = 1
wks.Range("E1") = EachElement
Set myOlApp = Nothing
Set olns = Nothing
Set myinbox = Nothing
Set myItems = Nothing
End Sub
非常感谢您的及时帮助 我不能100%确定这是否解决了您的问题,但请尝试替换所有
wks.Cells(StartCount, ..) = EachElement(..)
与:
这可能会解决你的问题
Dim i As Integer
For i = 1 To UBound(EachElement)
wks.Cells(StartCount, i) = EachElement(i)
Next