review this code for ba of an email tracker in excel. its only getting responses from the inbox folder I want this tracker to be able to check for responses on all folder, from inbox and other folders also subfolders. Ill give the codes for all the modules below

for sheet1

Option Explicit

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    On Error GoTo ErrorHandler
    Call HyperlinkClicked(Target)
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while handling hyperlink: " & Err.Description, vbExclamation
    Debug.Print "Error in Worksheet_FollowHyperlink: " & Err.Description
    Resume Next
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error GoTo ErrorHandler
    If Not Intersect(Target, Me.Columns(1)) Is Nothing Then
        If Target.Hyperlinks.Count > 0 Then
            Call HyperlinkClicked(Target.Hyperlinks(1))
            Cancel = True
        End If
    End If
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while handling double-click: " & Err.Description
    Debug.Print "Error in Worksheet_BeforeDoubleClick: " & Err.Description
    Resume Next
End Sub


For thisworkbook

Option Explicit

Private Sub Workbook_Open()
    On Error GoTo ErrorHandler
    Call InitializeFullEmailTracker
    Application.OnTime Now + TimeSerial(0, 0, 5), "CheckEmailResponses" ' Delay to allow initialization
    Call StartResponseCheckTimer ' Start the timer for periodic checking
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while opening the workbook: " & Err.Description, vbExclamation
    Debug.Print "Error in Workbook_Open: " & Err.Description
    Resume Next
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error GoTo ErrorHandler
    Call StopResponseCheckTimer
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while closing the workbook: " & Err.Description, vbExclamation
    Debug.Print "Error in Workbook_BeforeClose: " & Err.Description
    Resume Next
End Sub


for datavisualizationmodule

Option Explicit

Sub CreateDataVisualization()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim chartSheet As Worksheet
    On Error Resume Next
    Set chartSheet = ThisWorkbook.Sheets("Charts")
    If chartSheet Is Nothing Then
        Set chartSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        chartSheet.Name = "Charts"
    End If
    On Error GoTo 0

    ' Clear existing charts
    chartSheet.Cells.Clear

    CreateStatusChart chartSheet, ws
    CreateResponseChart chartSheet, ws

    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in CreateDataVisualization: " & Err.Description, vbExclamation
    Debug.Print "Error in CreateDataVisualization: " & Err.Description
    Resume Next
End Sub

Sub CreateStatusChart(chartSheet As Worksheet, ws As Worksheet)
    On Error GoTo ErrorHandler
    Dim statusCounts As Object
    Set statusCounts = CreateObject("Scripting.Dictionary")

    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)
    Dim i As Long
    For i = 5 To lastRow
        Dim status As String
        status = ws.Cells(i, 3).Value ' Assuming Status is in Column C
        If statusCounts.Exists(status) Then
            statusCounts(status) = statusCounts(status) + 1
        Else
            statusCounts(status) = 1
        End If
    Next i

    ' Prepare data for chart
    Dim chartData As Range
    chartSheet.Cells(1, 1).Value = "Status"
    chartSheet.Cells(1, 2).Value = "Count"
    Dim index As Integer
    index = 2
    Dim key As Variant
    For Each key In statusCounts.Keys
        chartSheet.Cells(index, 1).Value = key
        chartSheet.Cells(index, 2).Value = statusCounts(key)
        index = index + 1
    Next key

    ' Create chart
    Dim cht As ChartObject
    Set cht = chartSheet.ChartObjects.Add(Left:=10, Top:=10, Width:=500, Height:=300)
    With cht.Chart
        .SetSourceData Source:=chartSheet.Range("A1:B" & index - 1)
        .ChartType = xlPie
        .HasTitle = True
        .ChartTitle.Text = "Email Status Distribution"
        .Legend.Position = xlLegendPositionRight
    End With
    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in CreateStatusChart: " & Err.Description, vbExclamation
    Debug.Print "Error in CreateStatusChart: " & Err.Description
    Resume Next
End Sub

Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
    On Error GoTo ErrorHandler
    Dim daysSinceResponse As Object
    Set daysSinceResponse = CreateObject("Scripting.Dictionary")

    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)
    Dim i As Long
    For i = 5 To lastRow
        If ws.Cells(i, 8).Value <> "" Then ' Assuming Last Response Date is in Column H
            Dim days As Long
            days = DateDiff("d", ws.Cells(i, 8).Value, Now)
            If daysSinceResponse.Exists(days) Then
                daysSinceResponse(days) = daysSinceResponse(days) + 1
            Else
                daysSinceResponse(days) = 1
            End If
        End If
    Next i

    ' Prepare data for chart
    Dim chartStartRow As Integer
    chartStartRow = chartSheet.Cells(chartSheet.Rows.Count, 1).End(xlUp).row + 2
    chartSheet.Cells(chartStartRow, 1).Value = "Days Since Last Response"
    chartSheet.Cells(chartStartRow, 2).Value = "Count"
    Dim index As Integer
    index = chartStartRow + 1
    Dim key As Variant
    For Each key In daysSinceResponse.Keys
        chartSheet.Cells(index, 1).Value = key
        chartSheet.Cells(index, 2).Value = daysSinceResponse(key)
        index = index + 1
    Next key

    ' Create chart
    Dim cht As ChartObject
    Set cht = chartSheet.ChartObjects.Add(Left:=10, Top:=320, Width:=500, Height:=300)
    With cht.Chart
        .SetSourceData Source:=chartSheet.Range("A" & chartStartRow & ":B" & index - 1)
        .ChartType = xlColumnClustered
        .HasTitle = True
        .ChartTitle.Text = "Days Since Last Response"
        .Axes(xlCategory).HasTitle = True
        .Axes(xlCategory).AxisTitle.Text = "Days"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "Count"
        .Axes(xlCategory).TickLabelSpacing = 1
    End With
    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in CreateResponseChart: " & Err.Description, vbExclamation
    Debug.Print "Error in CreateResponseChart: " & Err.Description
    Resume Next
End Sub


for helpermoduleOption Explicit

Public Function GetLastDataRow(ws As Worksheet) As Long
    On Error Resume Next
    ' Find the last row with data in column A
    GetLastDataRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
    ' Ensure we don't count the header row (row 4) as data
    If GetLastDataRow < 5 Then GetLastDataRow = 4
    On Error GoTo 0
End Function

Public Function GetNextAvailableRow(ws As Worksheet) As Long
    GetNextAvailableRow = GetLastDataRow(ws) + 1
    If GetNextAvailableRow < 5 Then GetNextAvailableRow = 5
End Function

Public Function GetPreference(prefName As String) As Variant
    Dim wsPreferences As Worksheet
    Set wsPreferences = ThisWorkbook.Sheets(SHEET_NAME_PREFERENCES)

    Dim lastRow As Long, i As Long
    lastRow = wsPreferences.Cells(wsPreferences.Rows.Count, 1).End(xlUp).row

    For i = 1 To lastRow
        If wsPreferences.Cells(i, 1).Value = prefName Then
            GetPreference = wsPreferences.Cells(i, 2).Value
            Exit Function
        End If
    Next i
    ' Default values if preference not found
    Select Case prefName
        Case "Response Check Interval (Minutes)"
            GetPreference = 1
        Case "First Follow-Up Interval (Days)"
            GetPreference = 1
        Case "Escalation Interval (Days)"
            GetPreference = 10
        Case Else
            GetPreference = ""
    End Select
End Function

For importexportmodule

Option Explicit

Sub ExportData()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim saveFileDialog As FileDialog
    Set saveFileDialog = Application.FileDialog(msoFileDialogSaveAs)
    With saveFileDialog
        .Title = "Save As CSV"
        .InitialFileName = "EmailTracker_" & Format(Now, "yyyy_mm_dd_hh_mm_ss") & ".csv"
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv", 1
        .Filters.Add "All Files", "*.*", 2
        .FilterIndex = 1
        If .Show = -1 Then
            Dim filePath As String
            filePath = .SelectedItems(1)
            ws.Copy
            With ActiveWorkbook
                .SaveAs Filename:=filePath, FileFormat:=xlCSV
                .Close SaveChanges:=False
            End With
            MsgBox "Data exported successfully!", vbInformation
        End If
    End With
    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in ExportData: " & Err.Description, vbExclamation
    Debug.Print "Error in ExportData: " & Err.Description
    Resume Next
End Sub

Sub ImportData()
    On Error GoTo ErrorHandler
    Dim openFileDialog As FileDialog
    Set openFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With openFileDialog
        .Title = "Import CSV"
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv", 1
        .Filters.Add "All Files", "*.*", 2
        .FilterIndex = 1
        If .Show = -1 Then
            Dim importFilePath As String
            importFilePath = .SelectedItems(1)

            Dim importWs As Worksheet
            Set importWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            importWs.Name = "ImportTemp"

            With importWs.QueryTables.Add(Connection:="TEXT;" & importFilePath, Destination:=importWs.Cells(1, 1))
                .TextFileParseType = xlDelimited
                .TextFileCommaDelimiter = True
                .Refresh BackgroundQuery:=False
            End With

            Dim ws As Worksheet
            Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

            Dim lastRow As Long
            lastRow = GetNextAvailableRow(ws) - 1

            Dim importLastRow As Long
            importLastRow = GetLastDataRow(importWs)

            ws.Range("A" & (lastRow + 1) & ":I" & (lastRow + importLastRow - 1)).Value = importWs.Range("A2:I" & importLastRow).Value

            Application.DisplayAlerts = False
            importWs.Delete
            Application.DisplayAlerts = True

            MsgBox "Data imported successfully!", vbInformation

            ' Reformat the sheet
            FormatTrackerSheet ws
        End If
    End With
    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in ImportData: " & Err.Description, vbExclamation
    Debug.Print "Error in ImportData: " & Err.Description
    Resume Next
End Sub

for setupmodule

Option Explicit

' Constants for sheet names and button captions
Public Const SHEET_NAME_MAIN As String = "Sheet1"
Public Const SHEET_NAME_LOG As String = "ActivityLog"
Public Const SHEET_NAME_FOLLOW_UP As String = "FollowUpMessages"
Public Const SHEET_NAME_PREFERENCES As String = "Preferences"
Public Const BTN_CAPTION_ADD As String = "Add to List"
Public Const BTN_CAPTION_DELETE As String = "Delete"
Public Const BTN_CAPTION_SEND_FOLLOW_UP As String = "Send Follow-Up"
Public Const BTN_CAPTION_CHECK_RESPONSES As String = "Check Responses"
Public Const BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL As String = "Send Follow-Up To All"
Public Const BACKUP_INTERVAL_HOURS As Integer = 1
Public Const DEFAULT_BACKUP_PATH As String = "C:\Backups\"

Sub InitializeFullEmailTracker()
    On Error GoTo ErrorHandler

    Dim wsMain As Worksheet, wsLog As Worksheet, wsFollowUp As Worksheet, wsPreferences As Worksheet
    Set wsMain = EnsureSheetExists(SHEET_NAME_MAIN)
    Set wsLog = EnsureSheetExists(SHEET_NAME_LOG)
    Set wsFollowUp = EnsureSheetExists(SHEET_NAME_FOLLOW_UP)
    Set wsPreferences = EnsureSheetExists(SHEET_NAME_PREFERENCES)

    SetupHeaders wsMain
    SetupInputFields wsMain
    SetupButtons wsMain
    SetupActivityLog wsLog
    SetupFollowUpMessages wsFollowUp
    SetupPreferences wsPreferences

    ' Format the tracker sheet
    FormatTrackerSheet wsMain

    ' Activate the main sheet
    wsMain.Activate

    MsgBox "Email Tracker Initialized. You're ready to go!", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
    Debug.Print "Error in InitializeFullEmailTracker: " & Err.Description
    Resume Next
End Sub

Function EnsureSheetExists(sheetName As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = sheetName
    End If
    Set EnsureSheetExists = ws
End Function

Sub SetupHeaders(ws As Worksheet)
    On Error GoTo ErrorHandler
    With ws
        ' Input labels
        .Cells(1, 1).Value = "Email Subject:"
        .Cells(1, 2).Value = "Recipients:"
        ' Data table headers starting from Row 4
        .Cells(4, 1).Value = "Email Subject"
        .Cells(4, 2).Value = "Recipients"
        .Cells(4, 3).Value = "Status"
        .Cells(4, 4).Value = "Remarks"
        .Cells(4, 5).Value = "Last Follow-Up Date"
        .Cells(4, 6).Value = "Delete"
        .Cells(4, 7).Value = "Send Follow-Up"
        .Cells(4, 8).Value = "Last Response Date" ' Column H
        .Cells(4, 9).Value = "Follow-Up Count" ' Column I
    End With
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up headers: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupHeaders: " & Err.Description
    Resume Next
End Sub

Sub SetupInputFields(ws As Worksheet)
    On Error GoTo ErrorHandler
    With ws
        .Cells(2, 1).Value = ""
        .Cells(2, 2).Value = ""
    End With
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up input fields: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupInputFields: " & Err.Description
    Resume Next
End Sub

Sub SetupButtons(ws As Worksheet)
    On Error GoTo ErrorHandler
    Dim shp As Shape
    Dim rng As Range

    ' Add To List button
    If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
        Set rng = ws.Range("D1:E1") ' Adjust the cell range for the button
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
        With shp
            .TextFrame.Characters.Text = BTN_CAPTION_ADD
            .OnAction = "AddEmailToList"
            .Name = "Button_AddToList"
            .Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
            .Line.Visible = msoFalse
            .Placement = xlMoveAndSize
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
    End If

    ' Check Responses button
    If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
        Set rng = ws.Range("D2:E2") ' Adjust the cell range for the button
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
        With shp
            .TextFrame.Characters.Text = BTN_CAPTION_CHECK_RESPONSES
            .OnAction = "CheckEmailResponses"
            .Name = "Button_CheckResponses"
            .Fill.ForeColor.RGB = RGB(0, 112, 192) ' Blue
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
            .Line.Visible = msoFalse
            .Placement = xlMoveAndSize
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
    End If

    ' Send Follow-Up To All button
    If Not ButtonExists(ws, BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL) Then
        Set rng = ws.Range("D3:E3") ' Adjust the cell range for the button
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
        With shp
            .TextFrame.Characters.Text = BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL
            .OnAction = "SendFollowUpToAll"
            .Name = "Button_SendFollowUpToAll"
            .Fill.ForeColor.RGB = RGB(255, 192, 0) ' Orange
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black text
            .Line.Visible = msoFalse
            .Placement = xlMoveAndSize
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
    End If
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up buttons: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupButtons: " & Err.Description
    Resume Next
End Sub

Sub SetupActivityLog(wsLog As Worksheet)
    On Error GoTo ErrorHandler
    With wsLog
        .Cells(1, 1).Value = "Date"
        .Cells(1, 2).Value = "Action"
    End With
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up activity log: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupActivityLog: " & Err.Description
    Resume Next
End Sub

Sub SetupFollowUpMessages(wsFollowUp As Worksheet)
    On Error GoTo ErrorHandler
    With wsFollowUp
        .Cells(1, 1).Value = "Type"
        .Cells(1, 2).Value = "Message"
        .Cells(1, 3).Value = "Escalation Recipient" ' New column
        .Cells(2, 1).Value = "Follow-Up Message"
        .Cells(3, 1).Value = "Escalation Message"
        .Cells(2, 2).Value = "This is a follow-up. Please let us know if you need any further information."
        .Cells(3, 2).Value = "We have not received a response. This is an escalation email. Please respond at your earliest convenience."
        .Cells(3, 3).Value = "" ' Escalation recipient email, to be filled by user
    End With
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up follow-up messages: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupFollowUpMessages: " & Err.Description
    Resume Next
End Sub

Sub SetupPreferences(wsPreferences As Worksheet)
    On Error GoTo ErrorHandler
    With wsPreferences
        .Cells(1, 1).Value = "Backup Path"
        .Cells(1, 2).Value = DEFAULT_BACKUP_PATH
        .Cells(2, 1).Value = "Backup Interval (Hours)"
        .Cells(2, 2).Value = BACKUP_INTERVAL_HOURS
        .Cells(3, 1).Value = "First Follow-Up Interval (Days)"
        .Cells(3, 2).Value = 1
        .Cells(4, 1).Value = "Escalation Interval (Days)"
        .Cells(4, 2).Value = 10
        .Cells(5, 1).Value = "Response Check Interval (Minutes)"
        .Cells(5, 2).Value = 1 ' Default 1 minute
        ' You can add more settings here
    End With
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while setting up preferences: " & Err.Description, vbExclamation
    Debug.Print "Error in SetupPreferences: " & Err.Description
    Resume Next
End Sub

Function ButtonExists(ws As Worksheet, caption As String) As Boolean
    Dim shp As Shape
    ButtonExists = False
    For Each shp In ws.Shapes
        If shp.Type = msoShapeRectangle Or shp.Type = msoShapeRoundedRectangle Then
            If shp.TextFrame.Characters.Text = caption Then
                ButtonExists = True
                Exit Function
            End If
        End If
    Next shp
End Function

Sub FormatTrackerSheet(ws As Worksheet)
    On Error Resume Next

    ' Format Header Row (Row 4)
    With ws.Range("A4:I4") ' Ensure it includes all relevant columns
        .Font.Bold = True
        .Interior.Color = RGB(0, 112, 192) ' Blue color
        .Font.Color = RGB(255, 255, 255) ' White text
        .HorizontalAlignment = xlCenter
    End With

    ' Auto-fit columns
    ws.Columns("A:I").AutoFit ' Update columns as needed

    ' Format Input Row
    With ws.Range("A2:B2")
        .Interior.Color = RGB(217, 225, 242) ' Light Blue
        .Font.Color = RGB(0, 0, 0) ' Black text
    End With

    ' Apply borders to all cells with data
    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)
    If lastRow >= 4 Then
        With ws.Range("A4:I" & lastRow) ' Ensure it includes all relevant columns
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThin
        End With
    End If

    ' Clear existing conditional formatting
    ws.Range("A5:I" & ws.Rows.Count).FormatConditions.Delete

    ' Apply conditional formatting to highlight rows with responses
    If lastRow >= 5 Then
        Dim dataRange As Range
        Set dataRange = ws.Range("A5:I" & lastRow)
        
        ' Highlight rows where "Remarks" is "Response Received"
        With dataRange
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$D5=""Response Received"""
            With .FormatConditions(.FormatConditions.Count)
                .Interior.Color = RGB(198, 239, 206) ' Light Green
            End With
        End With
        
        ' Highlight rows where "Status" is "Operator Replied"
        With dataRange
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$C5=""Operator Replied"""
            With .FormatConditions(.FormatConditions.Count)
                .Interior.Color = RGB(255, 255, 204) ' Light Yellow
            End With
        End With
        
        ' Highlight rows where "Status" is "You Replied"
        With dataRange
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$C5=""You Replied"""
            With .FormatConditions(.FormatConditions.Count)
                .Interior.Color = RGB(204, 229, 255) ' Light Blue
            End With
        End With
    End If

    ' Freeze panes to keep headers visible
    ws.Activate
    ws.Range("A5").Select
    ActiveWindow.FreezePanes = True

    On Error GoTo 0
End Sub


for utility module

Option Explicit

' Constants for Address Entry Types and Folders
Const olExchangeUserAddressEntry = 0
Const olExchangeRemoteUserAddressEntry = 5
Const olFolderInbox = 6
Const olFolderSentMail = 5

Dim responseCheckTimer As Date

Sub AddEmailToList()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim subject As String, recipients As String
    subject = Trim(ws.Cells(2, 1).Value)
    recipients = Trim(ws.Cells(2, 2).Value)

    If ValidateInput(subject, recipients) Then
        Dim nextRow As Long
        nextRow = GetNextAvailableRow(ws)

        AddEmailEntry ws, nextRow, subject, recipients
        LogAction "Added email: " & subject

        ClearInputFields ws

        ' Reformat the sheet to apply new styles
        FormatTrackerSheet ws
    End If
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred in AddEmailToList: " & Err.Description, vbExclamation
    Debug.Print "Error in AddEmailToList: " & Err.Description
    Resume Next
End Sub

Sub AddEmailEntry(ws As Worksheet, row As Long, subject As String, recipients As String)
    Dim emailList As String
    emailList = ExtractEmails(recipients)

    With ws
        .Hyperlinks.Add Anchor:=.Cells(row, 1), Address:="", _
                        SubAddress:="'Sheet1'!A" & row, _
                        TextToDisplay:=subject, _
                        ScreenTip:="Click to search conversation in Outlook"

        .Cells(row, 1).ClearComments
        .Cells(row, 1).AddComment subject
        .Cells(row, 1).Comment.Visible = False

        .Cells(row, 2).Value = emailList
        .Cells(row, 3).Value = "Followed Up"
        .Cells(row, 4).Value = "Awaiting Response"
        .Cells(row, 5).Value = Now ' Record date of follow-up
        .Cells(row, 8).Value = ""  ' Initialize Last Response Date
        .Cells(row, 9).Value = 0   ' Initialize Follow-Up Count

        AddDeleteButton ws, row
        AddSendFollowUpButton ws, row
    End With
End Sub

Sub AddDeleteButton(ws As Worksheet, row As Long)
    Dim shp As Shape
    Dim rng As Range
    Set rng = ws.Cells(row, 6)
    Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
    With shp
        .TextFrame.Characters.Text = BTN_CAPTION_DELETE
        .OnAction = "DeleteRow"
        .Name = "Delete_Button_" & row
        .Placement = xlMoveAndSize
        ' Format the button
        .Fill.ForeColor.RGB = RGB(255, 0, 0) ' Red color
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
        .Line.Visible = msoFalse
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
    End With
End Sub

Sub AddSendFollowUpButton(ws As Worksheet, row As Long)
    Dim shp As Shape
    Dim rng As Range
    Set rng = ws.Cells(row, 7)
    Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
    With shp
        .TextFrame.Characters.Text = BTN_CAPTION_SEND_FOLLOW_UP
        .OnAction = "SendFollowUp"
        .Name = "FollowUp_Button_" & row
        .Placement = xlMoveAndSize
        ' Format the button
        .Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green color
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
        .Line.Visible = msoFalse
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
    End With
End Sub

Sub deleteRow()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim shp As Shape
    Set shp = ws.Shapes(Application.Caller)

    Dim deleteRow As Long
    deleteRow = shp.TopLeftCell.row

    ' Delete related buttons
    DeleteButton "Delete_Button_" & deleteRow, ws
    DeleteButton "FollowUp_Button_" & deleteRow, ws

    ws.Rows(deleteRow).Delete

    ' Adjust button names for rows below
    Dim i As Long
    For i = deleteRow + 1 To GetLastDataRow(ws)
        On Error Resume Next
        ws.Shapes("Delete_Button_" & i).Name = "Delete_Button_" & (i - 1)
        ws.Shapes("FollowUp_Button_" & i).Name = "FollowUp_Button_" & (i - 1)
        On Error GoTo 0
    Next i

    LogAction "Deleted email entry from row " & deleteRow

    ' Reformat the sheet
    FormatTrackerSheet ws

    Exit Sub
ErrorHandler:
    MsgBox "Error deleting row. Please try again.", vbCritical
    Debug.Print "Error in DeleteRow: " & Err.Description
    Resume Next
End Sub

Sub DeleteButton(buttonName As String, ws As Worksheet)
    Dim shp As Shape
    On Error Resume Next
    Set shp = ws.Shapes(buttonName)
    If Not shp Is Nothing Then
        shp.Delete
    End If
    On Error GoTo 0
End Sub

Sub ClearInputFields(ws As Worksheet)
    With ws
        .Cells(2, 1).Value = ""
        .Cells(2, 2).Value = ""
    End With
End Sub

Sub LogAction(action As String)
    Dim wsLog As Worksheet
    Set wsLog = ThisWorkbook.Sheets(SHEET_NAME_LOG)

    Dim nextLogRow As Long
    nextLogRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).row + 1

    With wsLog
        .Cells(nextLogRow, 1).Value = Now
        .Cells(nextLogRow, 2).Value = action
    End With
End Sub

Function ExtractEmails(recipientStr As String) As String
    Dim regex As Object, matches As Object, match As Object
    Dim emailList As String
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Z|a-z]{2,7}\b"
    regex.Global = True

    Set matches = regex.Execute(recipientStr)

    For Each match In matches
        emailList = emailList & match.Value & "; "
    Next match

    If Len(emailList) > 2 Then
        ExtractEmails = Left(emailList, Len(emailList) - 2)
    Else
        ExtractEmails = ""
    End If
End Function

Sub SearchOutlookConversations(subject As String)
    Dim olApp As Object, olExplorer As Object
    Dim searchText As String

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.Logon "", "", False, False
    End If
    On Error GoTo 0

    If olApp Is Nothing Then
        MsgBox "Outlook is not installed or could not be started.", vbCritical
        Exit Sub
    End If

    ' Perform search
    searchText = "subject:""" & subject & """"
    Set olExplorer = olApp.ActiveExplorer
    If olExplorer Is Nothing Then
        Set olExplorer = olApp.Explorers.Add(olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox))
        olExplorer.Display
    End If
    olExplorer.Search searchText, 2 ' 2 = olSearchScopeAllFolders
    olExplorer.Activate
End Sub

Sub HyperlinkClicked(Target As Hyperlink)
    Dim ws As Worksheet, subject As String
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    If Not Target.Range.Comment Is Nothing Then
        subject = Target.Range.Comment.Text
    Else
        subject = Target.Range.Text
    End If

    Call SearchOutlookConversations(subject)
End Sub

Sub CheckEmailResponses()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)

    Dim i As Long
    For i = 5 To lastRow ' Start from row 5, where data begins
        ' Check if the row has data in column A
        If Trim(ws.Cells(i, 1).Value) <> "" Then
            Dim subject As String, recipients As String
            subject = ws.Cells(i, 1).Value
            recipients = ws.Cells(i, 2).Value

            Dim lastResponseDate As Date
            If IsDate(ws.Cells(i, 8).Value) Then
                lastResponseDate = ws.Cells(i, 8).Value
            Else
                lastResponseDate = #1/1/1900#
            End If

            Dim status As String
            status = DetermineEmailStatus(subject, lastResponseDate)

            Select Case status
                Case "You Replied"
                    ws.Cells(i, 3).Value = "You Replied"
                    ws.Cells(i, 4).Value = "Awaiting Response"
                Case "Operator Replied"
                    ws.Cells(i, 3).Value = "Operator Replied"
                    ws.Cells(i, 4).Value = "Response Received"
                    ws.Cells(i, 8).Value = Now ' Update Last Response Date
                    LogAction "Response received for email: " & subject
                Case "No Change"
                    ' Do nothing
                Case "Error"
                    ' Handle error if needed
            End Select
        End If
    Next i

    ' Reformat the sheet after updating statuses
    FormatTrackerSheet ws

    ' Call FollowUpEscalation to handle automatic follow-ups
    Call FollowUpEscalation

    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in CheckEmailResponses: " & Err.Description, vbExclamation
    Debug.Print "Error in CheckEmailResponses: " & Err.Description
    Resume Next
End Sub

Function DetermineEmailStatus(subject As String, lastResponseDate As Date) As String
    Dim olApp As Object, olNamespace As Object, olInbox As Object, olSentItems As Object
    Dim olItems As Object, olSentItemsFiltered As Object
    Dim filter As String
    Dim latestMail As Object
    Dim maxDate As Date

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.Logon "", "", False, False
    End If
    On Error GoTo 0

    If olApp Is Nothing Then
        DetermineEmailStatus = "Error"
        Exit Function
    End If

    Set olNamespace = olApp.GetNamespace("MAPI")

    ' Build filter for subject
    filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " ci_phrasematch '" & subject & "'"

    ' Search Inbox
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
    Set olItems = olInbox.Items.Restrict(filter)

    ' Search Sent Items
    Set olSentItems = olNamespace.GetDefaultFolder(olFolderSentMail)
    Set olSentItemsFiltered = olSentItems.Items.Restrict(filter)

    ' Combine Inbox and Sent Items
    Dim combinedItems As Collection
    Set combinedItems = New Collection

    Dim item As Object
    For Each item In olItems
        combinedItems.Add item
    Next item

    For Each item In olSentItemsFiltered
        combinedItems.Add item
    Next item

    ' Find the latest email
    If combinedItems.Count > 0 Then
        maxDate = #1/1/1900#
        For Each item In combinedItems
            Dim mailDate As Date
            If item.SentOn > item.ReceivedTime Then
                mailDate = item.SentOn
            Else
                mailDate = item.ReceivedTime
            End If

            If mailDate > maxDate Then
                maxDate = mailDate
                Set latestMail = item
            End If
        Next item

        If maxDate > lastResponseDate Then
            Dim senderEmail As String
            senderEmail = GetSMTPAddress(latestMail.Sender)

            Dim ownEmail As String
            ownEmail = GetSMTPAddress(olNamespace.CurrentUser.AddressEntry)

            If StrComp(senderEmail, ownEmail, vbTextCompare) = 0 Then
                ' Latest email is from us
                DetermineEmailStatus = "You Replied"
            Else
                ' Latest email is from recipient
                DetermineEmailStatus = "Operator Replied"
            End If
        Else
            DetermineEmailStatus = "No Change"
        End If
    Else
        DetermineEmailStatus = "No Change"
    End If

    ' Clean up
    Set olItems = Nothing
    Set olSentItemsFiltered = Nothing
    Set olInbox = Nothing
    Set olSentItems = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Function

Function GetSMTPAddress(olAddressEntry As Object) As String
    Dim senderEmailAddress As String
    On Error Resume Next
    If olAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or _
       olAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
        ' Exchange user
        senderEmailAddress = olAddressEntry.GetExchangeUser().PrimarySmtpAddress
        If senderEmailAddress = "" Then
            ' Try getting from Exchange remote user
            senderEmailAddress = olAddressEntry.GetExchangeRemoteUser().PrimarySmtpAddress
        End If
    Else
        ' Other types (POP3, IMAP, SMTP)
        senderEmailAddress = olAddressEntry.Address
    End If

    If senderEmailAddress = "" Then
        senderEmailAddress = olAddressEntry.Address
    End If

    GetSMTPAddress = senderEmailAddress
    On Error GoTo 0
End Function

Function ValidateInput(subject As String, recipients As String) As Boolean
    If Trim(subject) = "" Or Trim(recipients) = "" Then
        MsgBox "Please enter both subject and recipients!", vbExclamation
        ValidateInput = False
    Else
        ValidateInput = True
    End If
End Function

Sub SendEmail(recipients As String, subject As String, body As String)
    Dim olApp As Object, olMail As Object
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.Logon "", "", False, False
    End If
    On Error GoTo 0

    If olApp Is Nothing Then
        MsgBox "Outlook is not installed or could not be started.", vbCritical
        Exit Sub
    End If

    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = recipients
        .subject = subject
        .body = body
        .Send
    End With

    ' Clean up
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

Sub SendFollowUp()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
    Dim shp As Shape
    Set shp = ws.Shapes(Application.Caller)
    Dim row As Long
    row = shp.TopLeftCell.row

    Dim lastFollowUpDate As Date
    If IsDate(ws.Cells(row, 5).Value) Then
        lastFollowUpDate = ws.Cells(row, 5).Value
    Else
        lastFollowUpDate = #1/1/1900#
    End If

    Dim followUpIntervalDays As Integer
    followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
    If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
        followUpIntervalDays = 1
    End If

    If DateDiff("d", lastFollowUpDate, Now) < followUpIntervalDays Then
        MsgBox "A follow-up has already been sent within the specified interval for this email.", vbInformation
        Exit Sub
    End If

    Dim subject As String, recipients As String
    subject = ws.Cells(row, 1).Value
    recipients = ws.Cells(row, 2).Value

    Dim wsFollowUp As Worksheet
    Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
    Dim followUpMessage As String
    followUpMessage = wsFollowUp.Cells(2, 2).Value

    SendEmail recipients, subject, followUpMessage
    ws.Cells(row, 5).Value = Now
    ws.Cells(row, 3).Value = "Followed Up"
    ws.Cells(row, 4).Value = "Awaiting Response"

    ws.Cells(row, 9).Value = ws.Cells(row, 9).Value + 1 ' Increment Follow-Up Count

    LogAction "Sent follow-up for email: " & subject
    MsgBox "Follow-up email sent for: " & subject, vbInformation

    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in SendFollowUp: " & Err.Description, vbExclamation
    Debug.Print "Error in SendFollowUp: " & Err.Description
    Resume Next
End Sub

Sub StartResponseCheckTimer()
    Dim intervalMinutes As Double
    intervalMinutes = GetPreference("Response Check Interval (Minutes)")
    If intervalMinutes <= 0 Then intervalMinutes = 1 ' Default to 1 minute
    responseCheckTimer = Now + TimeSerial(0, intervalMinutes, 0)
    Application.OnTime responseCheckTimer, "CheckEmailResponses"
End Sub

Sub StopResponseCheckTimer()
    On Error Resume Next
    Application.OnTime responseCheckTimer, "CheckEmailResponses", , False
    On Error GoTo 0
End Sub

Sub SendFollowUpToAll()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)

    Dim i As Long
    For i = 5 To lastRow
        If ws.Cells(i, 1).Value <> "" Then
            ' Check if follow-up is needed
            Dim lastFollowUpDate As Date
            If IsDate(ws.Cells(i, 5).Value) Then
                lastFollowUpDate = ws.Cells(i, 5).Value
            Else
                lastFollowUpDate = #1/1/1900#
            End If

            Dim followUpIntervalDays As Integer
            followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
            If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
                followUpIntervalDays = 1
            End If

            If DateDiff("d", lastFollowUpDate, Now) >= followUpIntervalDays Then
                ' Send follow-up
                Dim subject As String, recipients As String
                subject = ws.Cells(i, 1).Value
                recipients = ws.Cells(i, 2).Value

                Dim wsFollowUp As Worksheet
                Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
                Dim followUpMessage As String
                followUpMessage = wsFollowUp.Cells(2, 2).Value

                SendEmail recipients, subject, followUpMessage
                ws.Cells(i, 5).Value = Now
                ws.Cells(i, 3).Value = "Followed Up"
                ws.Cells(i, 4).Value = "Awaiting Response"
                ws.Cells(i, 9).Value = ws.Cells(i, 9).Value + 1 ' Increment Follow-Up Count
                LogAction "Sent follow-up for email: " & subject
            End If
        End If
    Next i
    MsgBox "Follow-up emails sent to all pending items.", vbInformation

    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in SendFollowUpToAll: " & Err.Description, vbExclamation
    Debug.Print "Error in SendFollowUpToAll: " & Err.Description
    Resume Next
End Sub

Sub FollowUpEscalation()
    On Error GoTo ErrorHandler
    Dim ws As Worksheet, wsFollowUp As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
    Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)

    Dim lastRow As Long
    lastRow = GetLastDataRow(ws)

    Dim escalationMessage As String
    escalationMessage = wsFollowUp.Cells(3, 2).Value
    Dim escalationRecipient As String
    escalationRecipient = wsFollowUp.Cells(3, 3).Value

    Dim escalationInterval As Integer
    escalationInterval = GetPreference("Escalation Interval (Days)")
    If IsEmpty(escalationInterval) Or Not IsNumeric(escalationInterval) Then
        escalationInterval = 10
    End If

    Dim followUpIntervalDays As Integer
    followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
    If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
        followUpIntervalDays = 1
    End If

    Dim i As Long
    For i = 5 To lastRow
        If ws.Cells(i, 1).Value <> "" Then
            Dim status As String
            status = ws.Cells(i, 3).Value
            Dim remarks As String
            remarks = ws.Cells(i, 4).Value

            Dim lastFollowUpDate As Date
            If IsDate(ws.Cells(i, 5).Value) Then
                lastFollowUpDate = ws.Cells(i, 5).Value
            Else
                lastFollowUpDate = #1/1/1900#
            End If

            Dim followUpCount As Integer
            followUpCount = ws.Cells(i, 9).Value

            Dim daysSinceFollowUp As Integer
            daysSinceFollowUp = DateDiff("d", lastFollowUpDate, Now)

            ' Check if it's time to send a follow-up
            If remarks = "Awaiting Response" Then
                If daysSinceFollowUp >= followUpIntervalDays Then
                    ' Send follow-up
                    SendFollowUpForRow i
                    ws.Cells(i, 3).Value = "Followed Up"
                    ws.Cells(i, 4).Value = "Awaiting Response"
                    ws.Cells(i, 5).Value = Now ' Update last follow-up date
                    ws.Cells(i, 9).Value = followUpCount + 1 ' Increment Follow-Up Count
                    LogAction "Automatically sent follow-up for email: " & ws.Cells(i, 1).Value
                End If

                ' Optionally, escalate after a certain number of follow-ups or days
                If followUpCount >= 5 Or daysSinceFollowUp >= escalationInterval Then
                    If escalationRecipient <> "" Then
                        ForwardLatestResponse ws.Cells(i, 1).Value, escalationMessage, escalationRecipient
                        ws.Cells(i, 3).Value = "Escalated"
                        ws.Cells(i, 4).Value = "Awaiting Response"
                        LogAction "Escalated email: " & ws.Cells(i, 1).Value
                    End If
                End If
            End If
        End If
    Next i

    ' Reformat the sheet after updating statuses
    FormatTrackerSheet ws

    ' Restart the timer for the next check
    Call StartResponseCheckTimer

    Exit Sub
ErrorHandler:
    MsgBox "An error occurred in FollowUpEscalation: " & Err.Description, vbExclamation
    Debug.Print "Error in FollowUpEscalation: " & Err.Description
    Resume Next
End Sub

Sub SendFollowUpForRow(row As Long)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim subject As String, recipients As String
    subject = ws.Cells(row, 1).Value
    recipients = ws.Cells(row, 2).Value

    Dim wsFollowUp As Worksheet
    Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
    Dim followUpMessage As String
    followUpMessage = wsFollowUp.Cells(2, 2).Value

    SendEmail recipients, subject, followUpMessage
End Sub

Sub ForwardLatestResponse(subject As String, body As String, escalationRecipient As String)
    Dim olApp As Object, olNamespace As Object, olInbox As Object, olSentItems As Object
    Dim olItems As Object, latestMail As Object
    Dim filter As String

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.Logon "", "", False, False
    End If
    On Error GoTo 0

    If olApp Is Nothing Then
        MsgBox "Outlook is not installed or could not be started.", vbCritical
        Exit Sub
    End If

    Set olNamespace = olApp.GetNamespace("MAPI")

    ' Build filter for subject
    filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " ci_phrasematch '" & subject & "'"

    ' Search Inbox
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
    Set olItems = olInbox.Items.Restrict(filter)

    ' Search Sent Items
    Set olSentItems = olNamespace.GetDefaultFolder(olFolderSentMail)
    Set olSentItemsFiltered = olSentItems.Items.Restrict(filter)

    ' Combine Inbox and Sent Items
    Dim combinedItems As Collection
    Set combinedItems = New Collection

    Dim item As Object
    For Each item In olItems
        combinedItems.Add item
    Next item

    For Each item In olSentItemsFiltered
        combinedItems.Add item
    Next item

    ' Find the latest email
    If combinedItems.Count > 0 Then
        Set latestMail = combinedItems(1)
        Dim maxDate As Date
        maxDate = #1/1/1900#
        For Each item In combinedItems
            Dim mailDate As Date
            If item.SentOn > item.ReceivedTime Then
                mailDate = item.SentOn
            Else
                mailDate = item.ReceivedTime
            End If

            If mailDate > maxDate Then
                maxDate = mailDate
                Set latestMail = item
            End If
        Next item

        If Not latestMail Is Nothing Then
            Dim olForward As Object
            Set olForward = latestMail.Forward
            With olForward
                .To = escalationRecipient
                .body = body & vbCrLf & .body
                .Send
            End With
        Else
            ' No email to forward, send new email
            Dim olMail As Object
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = escalationRecipient
                .subject = "Escalation: " & subject
                .body = body
                .Send
            End With
        End If
    Else
        ' No matching email found, send new escalation email
        Dim olMail As Object
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = escalationRecipient
            .subject = "Escalation: " & subject
            .body = body
            .Send
        End With
    End If

    ' Clean up
    Set olForward = Nothing
    Set olItems = Nothing
    Set olSentItemsFiltered = Nothing
    Set olInbox = Nothing
    Set olSentItems = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub



can you also create buttons for other functionalities like datavisualiyation, import and export and also a close tracker button that will save the tracker and close it. you may place this button besides the buttons for add to tracker, check responses and followup to all button. send me first the updated module codes for shee1, thisworkbook, setupmodule, helpermodule and after that ask me first if you can send the rest of the module codes for importexportmodule and utility module and also other modules if you need to add more modules