结合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

尝试添加代码之后最终选择和LEAV断字“选择'

我的意思是，试试这个

... 
End Select 

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

和NOT：

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

HTH

菲利普