I have this vba codes for my email tracker in excel

for DataVisualiyationModule

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

    CreateStatusChart chartSheet, ws
    CreateResponseChart chartSheet, ws
End Sub

Sub CreateStatusChart(chartSheet As Worksheet, ws As Worksheet)
    ' Existing code...
End Sub

Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
    ' Existing code...
End Sub

' Update: Changed Sub to Function
Function GetLastDataRow(ws As Worksheet) As Long
    GetLastDataRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
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"
        .FilterIndex = 2
        .Filters.Add "CSV Files", "*.csv", 1
        .Filters.Add "All Files", "*.*", 2
        If .Show = -1 Then
            ws.Copy
            ActiveWorkbook.SaveAs Filename:=.SelectedItems(1), FileFormat:=xlCSV
            ActiveWorkbook.Close SaveChanges:=False
            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"
        .InitialFileName = ""
        .FilterIndex = 1
        .Filters.Add "CSV Files", "*.csv", 1
        .Filters.Add "All Files", "*.*", 2
        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) & ":H" & (lastRow + importLastRow - 1)).Value = importWs.Range("A2:H" & importLastRow).Value

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

            MsgBox "Data imported successfully!", vbInformation
        End If
    End With
End Sub

' Update: Changed Sub to Function
Function GetNextAvailableRow(ws As Worksheet) As Long
    GetNextAvailableRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row + 1
    If GetNextAvailableRow < 3 Then GetNextAvailableRow = 3
End Function

' Update: Changed Sub to Function
Function GetLastDataRow(ws As Worksheet) As Long
    GetLastDataRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
End Function



For SetupModule

Option Explicit

' Updated Constants to include new settings
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

    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
        On Error Resume Next
        ws.Name = sheetName
        On Error GoTo 0
    End If
    Set EnsureSheetExists = ws
End Function

Sub SetupHeaders(ws As Worksheet)
    On Error GoTo ErrorHandler
    With ws
        .Cells(1, 1).Value = "Email Subject"
        .Cells(1, 2).Value = "Recipients"
        .Cells(1, 3).Value = "Status"
        .Cells(1, 4).Value = "Remarks"
        .Cells(1, 5).Value = "Last Follow-Up Date"
        .Cells(1, 6).Value = "Delete" ' Column F
        .Cells(1, 7).Value = "Send Follow-Up" ' Column G
        ' Removed column for "Check Responses" per entry
    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 = "Input Subject Here"
        .Cells(2, 2).Value = "Input Recipients Here"
    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 btn As Button
    ' Add To List button
    If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
        Set btn = ws.Buttons.Add(450, 10, 100, 20) ' Adjust position as needed
        With btn
            .caption = BTN_CAPTION_ADD
            .OnAction = "AddEmailToList"
        End With
    End If
    ' Check Responses button
    If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
        Set btn = ws.Buttons.Add(450, 40, 100, 20) ' Adjust position as needed
        With btn
            .caption = BTN_CAPTION_CHECK_RESPONSES
            .OnAction = "CheckEmailResponses"
        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(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."
    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
        ' 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 btn As Button
    ButtonExists = False
    For Each btn In ws.Buttons
        If btn.caption = caption Then
            ButtonExists = True
            Exit Function
        End If
    Next btn
End Function

For UtilityModule

Option Explicit

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
    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

        AddDeleteButton ws, row
        AddSendFollowUpButton ws, row
        ' Removed AddCheckResponsesButton
    End With
End Sub

Sub AddDeleteButton(ws As Worksheet, row As Long)
    Dim btn As Button
    Dim rng As Range
    Set rng = ws.Cells(row, 6)
    Set btn = ws.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
    With btn
        .caption = BTN_CAPTION_DELETE
        .OnAction = "DeleteRow"
        .Name = "Delete_Button_" & row
        .Placement = xlMoveAndSize
    End With
End Sub

Sub AddSendFollowUpButton(ws As Worksheet, row As Long)
    Dim btn As Button
    Dim rng As Range
    Set rng = ws.Cells(row, 7)
    Set btn = ws.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
    With btn
        .caption = BTN_CAPTION_SEND_FOLLOW_UP
        .OnAction = "SendFollowUp"
        .Name = "FollowUp_Button_" & row
        .Placement = xlMoveAndSize
    End With
End Sub

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

    Dim btn As Button
    On Error GoTo ErrHandler
    Set btn = ws.Buttons(Application.Caller)

    Dim deleteRow As Long
    deleteRow = btn.TopLeftCell.row

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

    LogAction "Deleted email entry from row " & deleteRow

    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 btn As Button
    On Error Resume Next
    Set btn = ws.Buttons(buttonName)
    If Not btn Is Nothing Then
        btn.Delete
    End If
    On Error GoTo 0
End Sub

Sub ClearInputFields(ws As Worksheet)
    With ws
        .Cells(2, 1).Value = "Input Subject Here"
        .Cells(2, 2).Value = "Input Recipients Here"
    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 GetNextAvailableRow(ws As Worksheet) As Long
    GetNextAvailableRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row + 1
    If GetNextAvailableRow < 3 Then GetNextAvailableRow = 3
End Function

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, olNamespace 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
    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(6))
        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 AutoBackup()
    ' Existing code...
End Sub

Sub AutoBackupScheduler()
    ' Existing code...
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 followUpMessage As String, escalationMessage As String
    followUpMessage = wsFollowUp.Cells(2, 2).Value
    escalationMessage = wsFollowUp.Cells(3, 2).Value

    Dim firstFollowUpInterval As Integer, escalationInterval As Integer
    firstFollowUpInterval = GetPreference("First Follow-Up Interval (Days)")
    escalationInterval = GetPreference("Escalation Interval (Days)")

    Dim i As Long
    For i = 3 To lastRow
        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)

            If daysSinceFollowUp >= escalationInterval Then
                SendEmail recipients, subject, escalationMessage
                ws.Cells(i, 3).Value = "Escalated"
                ws.Cells(i, 4).Value = "Awaiting Response"
                ws.Cells(i, 5).Value = Now
                LogAction "Escalated email: " & subject
            ElseIf daysSinceFollowUp >= firstFollowUpInterval Then
                SendEmail recipients, subject, followUpMessage
                ws.Cells(i, 5).Value = Now
                LogAction "Sent follow-up for email: " & subject
            End If
        End If
    Next i
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 = 3 To lastRow
        If ws.Cells(i, 3).Value <> "Responded" Then
            Dim subject As String, recipients As String
            subject = ws.Cells(i, 1).Value
            recipients = ws.Cells(i, 2).Value

            If CheckForResponse(subject) Then
                ws.Cells(i, 3).Value = "Responded"
                ws.Cells(i, 4).Value = "Response Received"
                LogAction "Response received for email: " & subject
            End If
        End If
    Next i
    MsgBox "Response check completed!", vbInformation
End Sub

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

Function GetBackupPath() As String
    ' Existing code...
End Function

Function GetBackupInterval() As Integer
    ' Existing code...
End Function

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 "First Follow-Up Interval (Days)"
            GetPreference = 1
        Case "Escalation Interval (Days)"
            GetPreference = 10
        Case Else
            GetPreference = ""
    End Select
End Function

Function GetLastDataRow(ws As Worksheet) As Long
    GetLastDataRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
End Function

Sub SendEmail(recipients As String, subject As String, body As String)
    Dim olApp As Object, olNamespace As Object, olInbox As Object, olSentItems As Object
    Dim olItems As Object, olItem As Object, olReply As Object
    Dim filter As String, maxDate As Date, latestMail As Object
    Dim 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
    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(6) 'Inbox
    Set olSentItems = olNamespace.GetDefaultFolder(5) 'Sent Items

    ' 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
    maxDate = #1/1/1900#
    If olItems.Count > 0 Then
        Set latestMail = olItems(1)
        maxDate = latestMail.ReceivedTime
    End If

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

    If Not latestMail Is Nothing Then
        Set olReply = latestMail.ReplyAll
        With olReply
            .To = recipients ' Use recipients from the tracker
            .body = body & vbCrLf & .body ' Prepend follow-up message
            .Send
        End With
    Else
        ' If no email found, create new email
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = recipients
            .subject = subject
            .body = body
            .Send
        End With
    End If

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

Function CheckForResponse(subject As String) As Boolean
    Dim olApp As Object, olNamespace As Object, olInbox As Object, olItems As Object
    Dim filter As String, olItem As Object
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.Logon
    End If
    On Error GoTo 0

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

    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6) 'Inbox

    ' Build filter for subject
    filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " ci_phrasematch '" & subject & "'"
    Set olItems = olInbox.Items.Restrict(filter)
    olItems.Sort "ReceivedTime", True

    CheckForResponse = False
    If olItems.Count > 0 Then
        Set olItem = olItems(1)
        If olItem.ReceivedTime >= DateAdd("d", -10, Now) Then
            CheckForResponse = True
        End If
    End If

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

Sub SendFollowUp()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
    Dim btn As Button
    Set btn = ws.Buttons(Application.Caller)
    Dim row As Long
    row = btn.TopLeftCell.row

    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
    LogAction "Sent follow-up for email: " & subject
    MsgBox "Follow-up email sent for: " & subject, vbInformation
End Sub

for ThisWorkbook

Private Sub Workbook_Open()
    On Error GoTo ErrorHandler
    Call InitializeFullEmailTracker
    Call AutoBackupScheduler
    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 AutoBackup
    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 Sheet1

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


the remarks was initally set to no response or awaiting response when I click on check responses button it was updated to response received however when Im done checking the responses and theres now new responses anymore for the email thread and I click on check responses again the remarks still showed response received when I should be no reponse right? because theres no new responses anymore. This might affect the automatic daily check for responses for follow up . Can you also edit the whole layout of the tracker make it beautiful add colors,  deisgns and animations if possible. If you have suggestions to improve my tracker over all in performance, effeciency and productivity feel free to do those changes

Send me the entire new updated whole vba code for the tracker setup and the entire module that Ill need and where to use them. I want to copy and paste it in a new excel file