為 Outlook/excel 組合 VBA 代碼

Question

我有兩個單獨的代碼，我需要將它們合二為一。 我已經開始工作了，但是在嘗試添加第二部分時我犯了一個錯誤。 如何將第二部分添加到第一個代碼中？ 第一個代碼是將電子郵件正文從文件夾導出到 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

Answer 1

嘗試在End Select之后添加代碼並去掉“Select”這個詞

我的意思是，試試這個

...
End Select

Range("B2").Formula = "=M ....

而不是：

...
End Select
Select 
Range("B2").Formula = "=MID( ...

HTH

菲利普