为 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

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

和不是：

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

HTH

菲利普