check vba codes below for my email tracker and edit based on my request.

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, vbExclamation
    Debug.Print "Error in Worksheet_BeforeDoubleClick: " & Err.Description
    Resume Next
End Sub


for ThiwWorkbook

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()
    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
End Sub

Sub CreateStatusChart(chartSheet As Worksheet, ws As Worksheet)
    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:=400, Height:=300)
    With cht.Chart
        .SetSourceData Source:=chartSheet.Range("A1:B" & index - 1)
        .ChartType = xlPie
        .HasTitle = True
        .ChartTitle.Text = "Email Status Distribution"
    End With
End Sub

Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
    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(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:=400, 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"
    End With
End Sub


for HelperModule

Option 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()
    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
End Sub

Sub ImportData()
    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
        End If
    End With
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 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
    ' Add To List button
    If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 10, 150, 20) ' Adjust position as needed
        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
        End With
    End If
    ' Check Responses button
    If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 40, 150, 20) ' Adjust position as needed
        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
        End With
    End If
    ' Send Follow-Up To All button
    If Not ButtonExists(ws, "Send Follow-Up To All") Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 70, 150, 20) ' Adjust position as needed
        With shp
            .TextFrame.Characters.Text = "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
        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") ' Updated to include column I
        .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 ' Updated to include column I

    ' 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)
    With ws.Range("A4:I" & lastRow) ' Updated to include column I
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With

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

    ' Apply conditional formatting to highlight rows with new responses
    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"""
        .FormatConditions(1).Interior.Color = RGB(198, 239, 206) ' Light Green
    End With

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

    On Error GoTo 0
End Sub


For UtilityModule

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()
    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
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 = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
    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 = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
    End With
End Sub

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

    Dim shp As Shape
    On Error GoTo ErrHandler
    Set shp = ws.Shapes(Application.Caller)

    Dim deleteRow As Long
    deleteRow = shp.TopLeftCell.row

    ws.Rows(deleteRow).Delete
    ' Delete related buttons
    DeleteButton "Delete_Button_" & deleteRow, ws
    DeleteButton "FollowUp_Button_" & deleteRow, ws

    ' 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

ErrHandler:
    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 = GetNextAvailableRow(wsLog)

    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()
    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 previousStatus As String
            previousStatus = ws.Cells(i, 3).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)

            If status = "Awaiting Response" Then
                ws.Cells(i, 3).Value = "Followed Up"
                ws.Cells(i, 4).Value = "Awaiting Response"
                ' Remove highlight
            ElseIf status = "Response Received" Then
                ws.Cells(i, 3).Value = "Responded"
                ws.Cells(i, 4).Value = "Response Received"
                ws.Cells(i, 8).Value = Now ' Update Last Response Date
                LogAction "Response received for email: " & subject
            End If
        End If
    Next i

    ' Reformat the sheet after updating statuses
    FormatTrackerSheet ws

    ' Restart the timer
    Call StartResponseCheckTimer
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
        MsgBox "Outlook is not installed or could not be started.", vbCritical
        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 = "Awaiting Response"
            Else
                ' Latest email is from recipient
                DetermineEmailStatus = "Response Received"
            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()
    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

    If DateDiff("d", lastFollowUpDate, Now) = 0 Then
        MsgBox "A follow-up has already been sent today 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
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()
    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

            If DateDiff("d", lastFollowUpDate, Now) >= 1 Then ' Only if a day has passed
                ' 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
End Sub

Sub FollowUpEscalation()
    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 escalationInterval = "" Then escalationInterval = 10

    Dim i As Long
    For i = 5 To lastRow
        If ws.Cells(i, 1).Value <> "" Then
            If ws.Cells(i, 3).Value = "Followed Up" And ws.Cells(i, 4).Value = "Awaiting Response" Then
                Dim subject As String, recipients As String
                subject = ws.Cells(i, 1).Value
                recipients = ws.Cells(i, 2).Value

                Dim daysSinceFollowUp As Integer
                daysSinceFollowUp = DateDiff("d", CDate(ws.Cells(i, 5).Value), Now)

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

                If daysSinceFollowUp >= escalationInterval Or followUpCount >= 10 Then
                    ' Forward the latest response
                    ForwardLatestResponse subject, escalationMessage, escalationRecipient
                    ws.Cells(i, 3).Value = "Escalated"
                    ws.Cells(i, 4).Value = "Awaiting Response"
                    LogAction "Escalated email: " & subject
                End If
            End If
        End If
    Next i
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")
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
    Set olSentItems = olNamespace.GetDefaultFolder(olFolderSentMail)

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

    ' Search Inbox
    Set olItems = olInbox.Items.Restrict(filter)
    olItems.Sort "ReceivedTime", True

    If olItems.Count > 0 Then
        Set latestMail = olItems(1)
    Else
        ' Search Sent Items
        Set olItems = olSentItems.Items.Restrict(filter)
        olItems.Sort "SentOn", True
        If olItems.Count > 0 Then
            Set latestMail = olItems(1)
        End If
    End If

    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

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






I the last follow up was on 09/27 and theres no new response for the email when I open the tracker again on 9/29 the tracker didnt send any follow up automatically. manual send of follow up button works though however I want the tracker to be able to send automatic follow up message when theres no new responses 24 from the last follow up date. Also the tracker checks the status of the emails automatically every minute right can you make the tracker remove the highlight when theres no new responses to the emails and also in the status column canyou add status there for the lastest in the email thread tell if I replied of the operators replied.