Finding email items with a certain text in the subject line - optimization

Question

I have basically semi-completed my VBA code for a project but I feel like it needs to be improved or optimized. Can I ask for help on what to change/modify/remove/optimize?

I am relatively new to VBA.

My code is the following:

Function WorksheetExists(sheet_name As String, Optional wb As Workbook) As Boolean
    Dim ws As Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook

    On Error Resume Next
        Set ws = wb.Sheets(sheet_name)
    On Error GoTo 0

    WorksheetExists = Not ws Is Nothing
End Function

Sub GetEmailDetailsInWorksheets()
    Dim outlook_app As Outlook.Application
    Dim namespace As Outlook.namespace

    Dim folders_collection As New Collection
    Dim folder As Outlook.MAPIFolder
    Dim sub_folder As Outlook.MAPIFolder
    Dim obj_mail As Outlook.MailItem
    Dim obj_item
    Dim row_number As Long
    Dim msgs_found_counter As Long
    Dim working_ws As Worksheet
    Dim active_cell_value As String

    Set outlook_app = New Outlook.Application
    Set namespace = outlook_app.GetNamespace("MAPI")
    Set working_ws = Sheets("Working")
    active_cell_value = ActiveCell.Value

    For Each folder In namespace.Folders
        For Each sub_folder In folder.Folders
            folders_collection.Add sub_folder
        Next sub_folder
    Next

    row_number = 4
    msgs_found_counter = 0

    If ActiveSheet.Name = "Working" Then
        If active_cell_value <> "" Then
            If WorksheetExists(active_cell_value) = False Then
                Sheets.Add(After:=Sheets("Working")).Name = active_cell_value
                Cells(row_number - 1, 1) = "Entry ID"
                Cells(row_number - 1, 2) = "Folder Path"
                Cells(row_number - 1, 3) = "Received Time"
                Cells(row_number - 1, 4) = "Sender"
                Cells(row_number - 1, 5) = "Recipients"
                Cells(row_number - 1, 6) = "Email Subject"
                MsgBox "PRESS OK TO CONTINUE."

                Do While folders_collection.Count > 0
                    Set folder = folders_collection(1) 'Get next folder to process
                    folders_collection.Remove 1        'Remove that folder from the collection

                    Application.StatusBar = folder.FolderPath

                    For Each obj_item In folder.Items
                        If obj_item.Class = olMail And InStr(1, obj_item.Subject, active_cell_value, vbTextCompare) > 0 Then
                            Set obj_mail = obj_item
                            Application.StatusBar = row_number & " - " & folder.FolderPath

                            On Error Resume Next
                            Cells(row_number, 1) = obj_mail.EntryID
                            Cells(row_number, 2) = folder.FolderPath
                            Cells(row_number, 3) = obj_mail.ReceivedTime
                            Cells(row_number, 4) = obj_mail.Sender
                            Cells(row_number, 5) = obj_mail.To
                            Cells(row_number, 6) = obj_mail.Subject
                            On Error GoTo 0

                            row_number = row_number + 1
                            msgs_found_counter = msgs_found_counter + 1
                        End If
                    Next obj_item

                    'Check for subfolders
                    For Each sub_folder In folder.Folders
                        folders_collection.Add sub_folder, before:=1
                    Next
                Loop
                MsgBox msgs_found_counter & " message/s found for """ & active_cell_value & """"
                Range("A4").Select
            Else
                MsgBox "A sheet matching the selected cell already exists. Redirecting you now..."
                Worksheets(active_cell_value).Activate
            End If
        Else
            MsgBox "Active cell is blank."
        End If
    Else
        MsgBox "You are in the wrong worksheet. Try again."
    End If

    Application.StatusBar = False
End Sub

Any guidance would be highly appreciated. I need help with the nested ifs or simplications of any lines of code. Thank you.

Answer 1

Restrict cuts down on the number of items to process.

This type of filter can simulate InStr:

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & _
  " LIKE '%" & active_cell_value & "%'"

---

Option Explicit

Function WorksheetExists(sheet_name As String, Optional wb As Workbook) As Boolean
    Dim ws As Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook

    On Error Resume Next
    Set ws = wb.Sheets(sheet_name)
    On Error GoTo 0

    WorksheetExists = Not ws Is Nothing
End Function

Sub GetEmailDetailsInWorksheets()

    Dim outlook_app As Outlook.Application
    Dim namespace As Outlook.namespace

    Dim folders_collection As New Collection
    Dim folder As Outlook.MAPIFolder
    Dim sub_folder As Outlook.MAPIFolder
    Dim obj_mail As Outlook.MailItem
    Dim obj_item
    Dim row_number As Long
    Dim msgs_found_counter As Long
    Dim working_ws As Worksheet
    Dim active_cell_value As String

    Dim strFilter As String
    Dim foundItems As Items

    Set outlook_app = New Outlook.Application
    Set namespace = outlook_app.GetNamespace("MAPI")
    Set working_ws = Sheets("Working")
    active_cell_value = ActiveCell.Value

    For Each folder In namespace.Folders
        For Each sub_folder In folder.Folders
            'Debug.Print sub_folder
            folders_collection.Add sub_folder
        Next sub_folder
    Next

    row_number = 4
    msgs_found_counter = 0

    If ActiveSheet.Name = "Working" Then
        If active_cell_value <> "" Then
            If WorksheetExists(active_cell_value) = False Then
                Sheets.Add(After:=Sheets("Working")).Name = active_cell_value
                Cells(row_number - 1, 1) = "Entry ID"
                Cells(row_number - 1, 2) = "Folder Path"
                Cells(row_number - 1, 3) = "Received Time"
                Cells(row_number - 1, 4) = "Sender"
                Cells(row_number - 1, 5) = "Recipients"
                Cells(row_number - 1, 6) = "Email Subject"
                MsgBox "PRESS OK TO CONTINUE."

                Do While folders_collection.Count > 0

                    Set folder = folders_collection(1) 'Get next folder to process
                    Debug.Print folder
                    folders_collection.Remove 1        'Remove that folder from the collection

                    Application.StatusBar = folder.FolderPath

                    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & _
                      " LIKE '%" & active_cell_value & "%'"
                    Debug.Print "strFilter: " & strFilter

                    Set foundItems = folder.Items.Restrict(strFilter)
                    Debug.Print "olResults.Count: " & foundItems.Count

                    For Each obj_item In foundItems

                        If obj_item.Class = olMail Then

                            Set obj_mail = obj_item
                            Application.StatusBar = row_number & " - " & folder.FolderPath

                            ' Likely not needed after verifying Class = olMail
                            'On Error Resume Next
                            Cells(row_number, 1) = obj_mail.EntryID
                            Cells(row_number, 2) = folder.FolderPath
                            Cells(row_number, 3) = obj_mail.ReceivedTime
                            Cells(row_number, 4) = obj_mail.Sender
                            Cells(row_number, 5) = obj_mail.To
                            Cells(row_number, 6) = obj_mail.Subject
                            'On Error GoTo 0

                            row_number = row_number + 1
                            msgs_found_counter = msgs_found_counter + 1
                        End If
                    Next obj_item

                    'Check for subfolders
                    For Each sub_folder In folder.Folders
                        folders_collection.Add sub_folder, before:=1
                    Next
                Loop
                MsgBox msgs_found_counter & " message/s found for """ & active_cell_value & """"
                Range("A4").Select
            Else
                MsgBox "A sheet matching the selected cell already exists. Redirecting you now..."
                Worksheets(active_cell_value).Activate
            End If
        Else
            MsgBox "Active cell is blank."
        End If
    Else
        MsgBox "You are in the wrong worksheet. Try again."
    End If

    Application.StatusBar = False
End Sub