Export from Outlook to Excel

Option Explicit
Public gblStopProcessing As Boolean
Sub ReadOutlookMessages()
' requires Microsoft Outlook Object Library (Tools/References}
Dim wb As Workbook
Dim ws As Worksheet
Dim wsAudit As Worksheet
Dim wsControl As Worksheet
Dim objFolder As Object
Dim objMsg As Object
Dim objNSpace As Object
'
Dim objOutlook As Outlook.Application
'
Dim blRecordsHaveFormulas As Boolean
Dim blColourCell As Boolean
'
Dim strDelimiter As String
Dim strText As String
Dim lngAuditRecord As Long
Dim lngKount As Long
Dim lngRecordsInEmail As Long
Dim lngRow As Long
Dim lngSaveType As Long ' olTXT save type
Dim lngTotalItems As Long
Dim lngTotalRecords As Long
Dim intFormulasEndColumn As Integer
Dim intFormulasStartColumn As Integer
Dim intFreefile As Integer
Dim intKount As Integer
'
 On Error GoTo HandleError
'
    ' Initialise:
     Set wb = ThisWorkbook
     Set wsControl = wb.Worksheets("Control Sheet")
     strDelimiter = wsControl.Range("B3").Value
     blColourCell = False
     lngAuditRecord = 1 ' Start row
     lngSaveType = 0 ' save as .txt
     lngTotalRecords = 0
'
    ' Read email messages:
     Application.ScreenUpdating = False
     Set objOutlook = CreateObject("Outlook.Application")
     Set objNSpace = objOutlook.GetNamespace("MAPI")
'
    ' Allow user to choose folder:#
     Set objFolder = objNSpace.pickfolder
    ' Check if cancelled:
     If objFolder Is Nothing Then
         gblStopProcessing = True
         MsgBox "Processing cancelled"
        Exit Sub
    End If
'
     lngTotalItems = objFolder.Items.Count
     If lngTotalItems = 0 Then
         MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
         gblStopProcessing = True
        GoTo HandleExit
    End If
     If lngTotalItems > 0 Then
         On Error Resume Next
             Application.DisplayAlerts = False
             wb.Worksheets("Merge Data").Delete
             wb.Worksheets("Audit").Delete
             Application.DisplayAlerts = True
         On Error GoTo HandleError
         wb.Worksheets.Add after:=Worksheets(Worksheets.Count)
         Set ws = ActiveSheet
         ws.Name = "Merge Data"
         wb.Worksheets.Add after:=Worksheets(Worksheets.Count)
         Set wsAudit = ActiveSheet
         wsAudit.Name = "Audit"
         wsAudit.Range("A1") = "Email data imported on " & Now()
         lngAuditRecord = lngAuditRecord + 1
         wsAudit.Cells(lngAuditRecord, 1) = "Subject"
         wsAudit.Cells(lngAuditRecord, 2) = "Sender's Email Address"
         wsAudit.Cells(lngAuditRecord, 3) = "Email Creation Time"
         wsAudit.Cells(lngAuditRecord, 4) = "Email Received Time"
         wsAudit.Cells(lngAuditRecord, 5) = "Records Imported"
         wsAudit.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
         Selection.EntireRow.Font.Bold = True
         Selection.HorizontalAlignment = xlCenter
         lngAuditRecord = lngAuditRecord + 1
         ws.Activate
         lngRow = 1 ' start row in worksheet "Merge Data"
         For lngKount = 1 To lngTotalItems
             Application.StatusBar = "Reading message " & lngKount & " of " & lngTotalItems
             Set objMsg = objFolder.Items(lngKount)
             objMsg.SaveAs ThisWorkbook.Path & "\temp321.txt", lngSaveType
             Close
             intFreefile = FreeFile
             Open ThisWorkbook.Path & "\temp321.txt" For Input As #intFreefile
             lngRecordsInEmail = 0
             Do Until EOF(intFreefile)
                 Line Input #intFreefile, strText
                 If InStr(1, strText, strDelimiter) > 0 Then
                     ws.Cells(lngRow, 1).Value = strText
                     If blColourCell Then
                         ws.Cells(lngRow, 1).Interior.ColorIndex = 35
                    End If
                     lngRow = lngRow + 1
                     lngTotalRecords = lngTotalRecords + 1
                     lngRecordsInEmail = lngRecordsInEmail + 1
                End If
             Loop
             Close
            ' switch cell colouring:
             blColourCell = Not blColourCell
'
' Update Audit record:
             On Error Resume Next
             wsAudit.Activate
             wsAudit.Cells(lngAuditRecord, 1) = objFolder.Items(lngKount).Subject
             wsAudit.Cells(lngAuditRecord, 2) = objFolder.Items(lngKount).SenderEmailAddress
             wsAudit.Cells(lngAuditRecord, 3) = objFolder.Items(lngKount).CreationTime
             wsAudit.Cells(lngAuditRecord, 4) = objFolder.Items(lngKount).ReceivedTime
             wsAudit.Cells(lngAuditRecord, 5) = lngRecordsInEmail
             wsAudit.Range("A1").Select
             wsAudit.Cells.Columns.AutoFit
             lngAuditRecord = lngAuditRecord + 1
             On Error GoTo HandleError
'
             ws.Activate
        Next lngKount
         Kill ThisWorkbook.Path & "\temp321.txt"
   End If
'
' Check that records have been found:
     If lngTotalRecords = 0 Then
         MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
         gblStopProcessing = True
        GoTo HandleExit
    End If

HandleExit:
     On Error Resume Next
     Application.ScreenUpdating = True
     Set objNSpace = Nothing
     Set objFolder = Nothing
     Set objMsg = Nothing
     Set objOutlook = Nothing
     Set ws = Nothing
     Set wsAudit = Nothing
     Set wsControl = Nothing
     Set wb = Nothing
'
     If Not gblStopProcessing Then
            MsgBox "Processing completed" & vbCrLf & vbCrLf & _
               "Please check results", vbOKOnly + vbInformation, "Information"
    End If
'
    Exit Sub
'
HandleError:
    MsgBox Err.Number & vbCrLf & Err.Description
    gblStopProcessing = True
    Resume HandleExit
End Sub

Option Explicit
Public gblStopProcessing As Boolean
Sub ReadOutlookMessages()
' requires Microsoft Outlook Object Library (Tools/References}
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objMsg As Object
Dim objNSpace As Object
'
Dim objOutlook As Outlook.Application
'
Dim strDelimiter As String
Dim strText As String
Dim lngTotalRecords As Integer
Dim lngRow As Long
Dim lngSaveType As Long ' olTXT save type
Dim lngTotalItems As Long
Dim intFreefile As Integer
Dim lngKount As Integer
Dim isDatum As Variant
On Error GoTo HandleError
' Initialise:
     Set wb = ThisWorkbook
     lngSaveType = 0 ' save as .txt
     lngTotalRecords = 0
     lngRow = 1 ' start row in worksheet "import"
 
' Read email messages:
      Application.ScreenUpdating = False
      Set objOutlook = CreateObject("Outlook.Application")
     Set objNSpace = objOutlook.GetNamespace("MAPI")
' Allow user to choose folder:#
     Set objFolder = objNSpace.pickfolder
' Check if cancelled:
     If objFolder Is Nothing Then
         gblStopProcessing = True
         MsgBox "Processing cancelled"
        Exit Sub
     End If
' Items in folder tellen
     lngTotalItems = objFolder.Items.Count
 
' Doorgaan indien mail gevonden
     If lngTotalItems = 0 Then
         MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
         gblStopProcessing = True
        GoTo HandleExit 'naar exit indien 0
     End If
 
     If lngTotalItems > 0 Then 'indien berichten in folder
 
         On Error Resume Next
             Application.DisplayAlerts = False
             wb.Worksheets("import").Delete     'sheet "import" verwijderen
             Application.DisplayAlerts = True
         On Error GoTo HandleError
 
            wb.Worksheets.Add after:=Worksheets(Worksheets.Count)  'sheet toevoegen
            Set ws = ActiveSheet
            ws.Name = "import"                                 ' naam nieuwe sheet wijzigen in "import"
 
 
 
 
 
         For lngKount = 1 To lngTotalItems 'van eerste mail tot totaal aantal mails
 
                 Set objMsg = objFolder.Items(lngKount)
                 objMsg.SaveAs ThisWorkbook.Path & "\temp321.txt", lngSaveType
                 Close
 
                 ws.Activate
 
                 intFreefile = FreeFile
                 Open ThisWorkbook.Path & "\temp321.txt" For Input As #intFreefile
 
                 Do Until EOF(intFreefile)
                     Line Input #intFreefile, strText
                     If strText <> "" Then
 
                     isDatum = IsDate(strText)
                     Select Case isDatum
                        Case True
                        ws.Cells(lngRow, 1).Value = DateValue(strText)
                        lngRow = lngRow + 1
                        Case Else
                        ws.Cells(lngRow, 1).Value = strText
                        lngRow = lngRow + 1
                     End Select
 
                     End If
                 Loop
                 Close
 
                 On Error Resume Next
                 On Error GoTo HandleError
 
                 ws.Activate
 
             Kill ThisWorkbook.Path & "\temp321.txt"
             MsgBox "call"
         Call FindValues
         Next lngKount
 
    End If
HandleExit:
     On Error Resume Next
     Application.ScreenUpdating = True
     Set objNSpace = Nothing
     Set objFolder = Nothing
     Set objMsg = Nothing
     Set objOutlook = Nothing
     Set ws = Nothing
     Set wb = Nothing
     Kill ThisWorkbook.Path & "\temp321.txt"
     Exit Sub
HandleError:
    MsgBox Err.Number & vbCrLf & Err.Description
    gblStopProcessing = True
    Resume HandleExit
 
End Sub
Sub FindValues()
Dim wb As Workbook
Dim ws As Worksheet
Dim wc As Worksheet
Dim wi As Worksheet
Dim isin() As Variant
Dim i, j, p, d, t As Integer
Dim isinnr As String
Dim isinToFind As String
Dim Foundisin As String
Dim FoundValue As Double
Dim FoundDate As Variant
Dim DateC As Variant
Dim isDatum As Variant
 
' Initialise:
    isinnr = "blabla"
    Foundisin = "blablabla"
    Set wb = ThisWorkbook
    Set wi = wb.Worksheets("import")
    Set wc = wb.Worksheets("carmignac")
    i = 2
    p = 1
' Get ISIN Numbers
    For i = 2 To 100
        isinnr = wc.Cells(1, i).Value
            Select Case isinnr
                Case Is <> ""
                ReDim Preserve isin(i - 1)
                isin(i - 1) = isinnr
                i = i + 1
                Case Else
                Exit For
            End Select
    Next
 
' Get NAV Date
        For d = 1 To 1000
            FoundDate = wi.Cells(d, 1).Text
 
            Select Case FoundDate
                Case "gepubliceerd op "
                FoundDate = DateValue(wi.Cells(d - 1, 1).Value)
                MsgBox FoundDate
                Exit For
                Case ""
                MsgBox "Geen datum gevonden"
                Exit Sub
            End Select
        Next
 
' Get NAV
    For j = 1 To UBound(isin)
        isinToFind = isin(j)
 
        Do Until Foundisin = isinToFind Or Foundisin = ""
        Foundisin = wi.Cells(p, 1).Text
        p = p + 1
        Loop
 
' Export to carmignac
    'Find NAV DATE
    For t = 2 To 10000
        DateC = wc.Cells(t, 1).Text
        isDatum = IsDate(DateC)
        Select Case isDatum
            Case True
            DateC = DateValue(DateC)
                Select Case DateC
                    Case FoundDate
                    Exit For
                    Case ""
                    MsgBox "Geen datum gevonden"
                    Exit Sub
                End Select
             End Select
    Next
 
    'paste NAV
    FoundValue = wi.Cells(p + 1, 1).Value
    wc.Cells(t, j + 1).Value = FoundValue
 
    Next j
 
'Exit
     Set ws = Nothing
     Set wb = Nothing
End Sub