1 つとして機能する必要がある 2 つの別個のコードがあります。最初の部分は機能しましたが、2 番目の部分を追加しようとすると間違いを犯しています。2 番目の部分を最初のコードに追加するにはどうすればよいですか? 最初のコードは、電子メールの本文をフォルダーから Excel にエクスポートしています。2番目の部分は、体の一部を独自の細胞に分解することになっています.
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