HELP--Extract Data from 2003 outlook transfer to excel spreadsheet

[mizsporty]

We are using outlook 2003/excel 2003. We have never done this, nor are we educated in code or understand this concept. Please explain our as if you are speaking someone grade school. We need a step by step instruction of how to extract specific data from outlook 2003 and have it go to excel 2003 spread sheet. We do not want all of our email used. Only those from named folder.

First Name

Last name

email

phone

age

sex

date of email

Please, we are spinning our wheels and do not know what to do.

 

[Diane Poremsky]

This code will get the fields if the patterns (including case) are exactly - select one or more messages in any folder and run the macro. See How to use VB Editor if you don't know how to use VBA.

First Name
Last name
email
phone
age
sex
date of email

Option Explicit
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim strFirst, strLast, strEmail, strPhone, strAge, strSex, strDate As String
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim i As Variant
    Dim strResult(7) As String
   Dim strTest(7) As String
    Dim obj As Object
   Dim Selection As Selection
      
            
 
enviro = CStr(Environ("USERPROFILE")) 
 
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("Sheet1")
   ' Process the message record
   Set olItem = Application.ActiveExplorer().Selection(1)
  
   'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1
     Debug.Print olItem.Body
    Set Reg1 = CreateObject("VBScript.RegExp")
   ' \s* = invisible spaces
   ' \d* = match digits
   ' \w* = match alphanumeric
    
 
Set Selection = Application.ActiveExplorer.Selection
 For Each obj In Selection
   Set olItem = obj
For i = 1 To 7 
 
With Reg1
   Select Case i
   Case 1
       .Pattern = "(First Name\s*(--)\s*(.*))\n\s*"
       .Global = False
      
   Case 2
       .Pattern = "(Last Name\s*(--)\s*(.*))\n\s*"
      .Global = False
        
   Case 3
       .Pattern = "(Email\s*(--)\s*(.*))\n\s*"
       .Global = False
   Case 4
       .Pattern = "(phone\s*(--)\s*(.*))\n\s*"
       .Global = False
   Case 5
       .Pattern = "(age\s*(--)\s*(.*))\n\s*"
       .Global = False
   Case 6
       .Pattern = "(sex\s*(--)\s*(.*))\n\s*"
       .Global = False
   Case 7
       .Pattern = "(date of email \s*(--)\s*(.*))\n\s*"
       .Global = False
   End Select
   
 
End With
 
  
    If Reg1.Test(olItem.Body) Then
   
       Set M1 = Reg1.Execute(olItem.Body)
       For Each M In M1
     
           strResult(i) = M.SubMatches(1)
           strTest(i) = M.SubMatches(2)
        strFirst = strTest(1) ' Trim(strResult(1))
        strLast = strTest(2) ' Trim(strTest(1))
        strEmail = strTest(3) ' Trim(strTest(2))
        strPhone = strTest(4) ' Trim(strResult(3))
        strAge = strTest(5) ' Trim(strResult(4))
        strSex = strTest(6) ' Trim(strResult(4))
        strDate = strTest(7) ' Trim(strResult(4))
 
          Next
   End If
 
   Next i
         
 
Debug.Print strFirst
   Debug.Print strLast
   Debug.Print strEmail
   Debug.Print strPhone
   Debug.Print strAge
   Debug.Print strSex
   Debug.Print strDate
 xlSheet.Range("B" & rCount) = strFirst
 xlSheet.Range("c" & rCount) = strLast
 xlSheet.Range("d" & rCount) = strEmail
 xlSheet.Range("e" & rCount) = strPhone
 xlSheet.Range("f" & rCount) = strAge
 xlSheet.Range("g" & rCount) = strSex
 xlSheet.Range("h" & rCount) = strDate
Next
    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
    End If
    Set M = Nothing
    Set M1 = Nothing
    Set Reg1 = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub