title: Combining VBA code for Outlook/excel
body: <p>I have two separate codes that I need to work as one. I've gotten the first to work, but I'm making a mistake when trying to add the second part. How do I get the second part added in to the first code? The first code is exporting the body of emails from a folder into excel. The second part is supposed to break out parts of the body into it's own cell.</p>
  
  <pre><code>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 &lt;&gt; "" 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 " &amp; intRow - 2 &amp; " 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 &lt; 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
  </code></pre>
  
  <p>The part I need to add in is:</p>
  
  <pre><code>    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" &amp; LastUsedRow), Type:=xlFillDefault 
  Range("C2").Select 
  Selection.AutoFill Destination:=Range("C2:C" &amp; LastUsedRow), Type:=xlFillDefault 
  Range("D2").Select 
  Selection.AutoFill Destination:=Range("D2:D" &amp; LastUsedRow), Type:=xlFillDefault 
  Range("E2").Select 
  Selection.AutoFill Destination:=Range("E2:E" &amp; LastUsedRow), Type:=xlFillDefault 
  Range("F2").Select 
  Selection.AutoFill Destination:=Range("F2:F" &amp; LastUsedRow), Type:=xlFillDefault 
  Range("G2").Select 
  Selection.AutoFill Destination:=Range("G2:G" &amp; 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 
  </code></pre>
  
  <p>Added 3/13</p>
  
  <pre><code>    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 &lt;&gt; "" 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
  </code></pre>