我有两个单独的代码需要作为一个代码工作。我已经得到了第一个工作，但是在尝试添加第二部分时我犯了一个错误。如何将第二部分添加到第一个代码中？第一个代码是将文件夹中的电子邮件正文导出到 excel 中。第二部分应该将身体的某些部分分解成自己的细胞。
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
我需要添加的部分是：
Select
Range("B2").Formula = "=MID(Trim(Clean(A2)),FIND(""Risk Owner:"",Trim(Clean(A2)))+13,FIND(""Counterparty:"",Trim(Clean(A2)))-FIND(""Risk Owner:"",Trim(Clean(A2)))-13)"
Range("C2").Formula = "=MID(Trim(Clean(A2)),FIND(""Counterparty:"",Trim(Clean(A2)))+15,FIND(""Trade ID:"",Trim(Clean(A2)))-FIND(""Counterparty:"",Trim(Clean(A2)))-15)"
Range("D2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Trade ID:"",TRIM(CLEAN(A2)))+11,FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))-FIND(""Trade ID:"",TRIM(CLEAN(A2)))-11)"
Range("E2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))+13,FIND(""Termination Method:"",TRIM(CLEAN(A2)))-FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))-13)"
Range("F2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Termination Method:"",TRIM(CLEAN(A2)))+21,FIND(""Termination amount:"",TRIM(CLEAN(A2)))-FIND(""Termination Method:"",TRIM(CLEAN(A2)))-21)"
Range("G2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Termination amount:"",TRIM(CLEAN(A2)))+21,FIND(""Expected Recovery:"",TRIM(CLEAN(A2)))-FIND(""Termination amount:"",TRIM(CLEAN(A2)))-21)"
'Copy formulas
Sheets("Import").Select
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B" & LastUsedRow), Type:=xlFillDefault
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C" & LastUsedRow), Type:=xlFillDefault
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D" & LastUsedRow), Type:=xlFillDefault
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E" & LastUsedRow), Type:=xlFillDefault
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F" & LastUsedRow), Type:=xlFillDefault
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & LastUsedRow), Type:=xlFillDefault
'Paste values to remove formulas
Sheets(Array("Import")).Select
Sheets("Import").Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
添加 3/13
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