组合Outlook/excel的VBA代码
我有两个独立的代码，我需要作为一个工作。我已经让第一部分开始工作，但是我在尝试添加第二部分时犯了一个错误。如何将第二部分添加到第一个代码中？第一个代码是将电子邮件正文从文件夹导出到excel中。第二部分被认为是将身体的各个部分分解成自己的细胞组合Outlook/excel的VBA代码,excel,vba,outlook,Excel,Vba,Outlook,我有两个独立的代码，我需要作为一个工作。我已经让第一部分开始工作，但是我在尝试添加第二部分时犯了一个错误。如何将第二部分添加到第一个代码中？第一个代码是将电子邮件正文从文件夹导出到excel中。第二部分被认为是将身体的各个部分分解成自己的细胞 Sub ExportMessagesToExcel() Dim olkMsg As Object, _ excApp As Object, _ excWkb As Object, _ excWks As Object, _
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String
strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
If strFilename <> "" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.VERSION, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strBuffer As String, _
strFilename As String, _
strTemp As String, _
arrLines As Variant, _
varLine As Variant, _
bolComments As Boolean
strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
If strFilename <> "" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Transaction Type:"
.Cells(1, 2) = "Select One:"
.Cells(1, 3) = "Area"
.Cells(1, 4) = "Store"
.Cells(1, 5) = "Date"
.Cells(1, 6) = "Iar Date"
.Cells(1, 7) = "Name of submitter"
.Cells(1, 8) = "Key Rec"
.Cells(1, 9) = "Issue"
.Cells(1, 10) = "Vendor #"
.Cells(1, 11) = "Vendor address"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
strBuffer = ""
bolComments = False
arrLines = Split(olkMsg.Body, vbCrLf)
For Each varLine In arrLines
strTemp = Trim(varLine)
If bolComments Then
Else
If Left(strTemp, 17) = "Transaction Type: " Then
excWks.Cells(intRow, 4) = Mid(strTemp, 17)
Else
If Left(strTemp, 14) = "Select one: " Then
excWks.Cells(intRow, 5) = Mid(strTemp, 16)
Else
If Left(strTemp, 5) = "Area: " Then
excWks.Cells(intRow, 6) = Mid(strTemp, 5)
Else
If Left(strTemp, 8) = "Store #: " Then
excWks.Cells(intRow, 7) = Mid(strTemp, 8)
Else
If Left(strTemp, 16) = "Date MM/DD/YYYY: " Then
excWks.Cells(intRow, 8) = Mid(strTemp, 16)
Else
If Left(strTemp, 28) = "IAR Week End Date MM/DD/YYYY: " Then
excWks.Cells(intRow, 9) = Mid(strTemp, 28)
Else
If Left(strTemp, 44) = "Name Title of Person Submitting Issue Sheet: " Then
excWks.Cells(intRow, 10) = Mid(strTemp, 14)
Else
If Left(strTemp, 29) = "Keyrec#: " Then
excWks.Cells(intRow, 11) = Mid(strTemp, 29)
Else
If Left(strTemp, 32) = "Detailed Description of Issue: " Then
excWks.Cells(intRow, 12) = Mid(strTemp, 32)
Else
If Left(strTemp, 9) = "Vendor #:" Then
bolComments = True
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next
excWks.Cells(intRow, 10) = strBuffer
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete."
End Sub
子ExportMessagesToExcel（）
作为对象的Dim olkMsg_
excApp作为对象_
excWkb作为对象_
以挖掘为对象_
intRow为整数_
intVersion作为整数_
strBuffer作为字符串_
strFilename作为字符串_
strTemp作为字符串_
作为变体_
varLine作为变体_
将注释设置为布尔值
strFilename=InputBox（“输入文件名（包括路径）以将导出的消息保存到。”，宏名称）
如果strFilename为“”，则
intVersion=GetOutlookVersion（）
设置excApp=CreateObject（“Excel.Application”）
Set excWkb=excApp.Workbooks.Add（）
设置excWks=excWkb.ActiveSheet
'编写Excel列标题
用excWks
.单元格（1，1）=“交易类型：”
.单元格（1，2）=“选择一个：”
.单元格（1,3）=“面积”
.单元格（1,4）=“存储”
.单元格（1,5）=“日期”
.单元格（1,6）=“Iar日期”
.单元格（1,7）=“提交人名称”
.单元格（1,8）=“密钥记录”
.单元格（1,9）=“问题”
.单元格（1,10）=“供应商”
.单元格（1，11）=“供应商地址”
以
intRow=2
'将消息写入电子表格
对于Application.ActiveExplorer.CurrentFolder.Items中的每个olkMsg
'仅导出邮件，不导出收据或约会请求等。
如果olkMsg.Class=olMail，则
'为要导出的邮件中的每个字段添加一行
strBuffer=“”
bolComments=False
arrLines=拆分（olkMsg.Body，vbCrLf）
对于arrLines中的每个varLine
strTemp=微调（变线）
如果你有意见的话
其他的
如果左（strTemp，17）=“交易类型：”则
excWks.单元格（intRow，4）=中间（strTemp，17）
其他的
如果左（strTemp，14）=“选择一个：”则
excWks.单元格（intRow，5）=中间（strTemp，16）
其他的
如果左（strTemp，5）=“面积：”则
excWks.单元格（intRow，6）=中间（strTemp，5）
其他的
如果左（strTemp，8）=“存储：”，则
excWks.CELL（intRow，7）=Mid（strTemp，8）
其他的
如果左（strTemp，16）=“日期MM/DD/YYYY:”则
excWks.CELL（intRow，8）=Mid（strTemp，16）
其他的
如果左（strTemp，28）=“IAR周结束日期MM/DD/YYYY:”则
excWks.Cells（intRow，9）=Mid（strTemp，28）
其他的
如果左（strTemp，44）=“提交问题单的人员姓名和职务：”则
excWks.CELL（intRow，10）=Mid（strTemp，14）
其他的
如果左（strTemp，29）=“Keyrec:”则
excWks.Cells（intRow，11）=Mid（strTemp，29）
其他的
如果左（strTemp，32）=“问题的详细描述：”则
excWks.单元格（intRow，12）=中间（strTemp，32）
其他的
如果左（strTemp，9）=“供应商：”，则
bolComments=True
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
如果结束
下一个
excWks.Cells（intRow，10）=strBuffer
intRow=intRow+1
如果结束
下一个
设置olkMsg=Nothing
excWkb.SaveAs strFilename
excWkb.关闭
如果结束
设置excWks=无
Set excWkb=无
设置excApp=Nothing
MsgBox“过程完成。”
端接头
...
End Select
Range("B2").Formula = "=M ....
...
End Select
Select
Range("B2").Formula = "=MID( ...
Philip您得到的错误是什么？您在代码中的何处得到错误？您想在代码中的何处添加第2部分-在它自己的过程中，在现有的过程中？谢谢您的帮助。。。让代码运行起来很有效。出局仍然不是我想的那样。我以为第二部分会将主体拆分成单元格，并在公式中的关键字之间提供值。这与您的公式有关，不是吗？我怀疑您需要通过A列中的值，然后调试B列、C列中的公式，依此类推……发布一些A列所包含内容的示例
...
End Select
Select
Range("B2").Formula = "=MID( ...