Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim cell As Range
    Dim emailPattern As String
    Dim regEx As Object
    Dim isEmail As Boolean
    
    ' Регулярное выражение для определения email
    emailPattern = "\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,}\b"
    
    ' Инициализация регулярного выражения
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = emailPattern
    regEx.IgnoreCase = True
    regEx.Global = True
    
    Application.EnableEvents = False
    
    For Each cell In Target
        If Not cell.Hyperlinks.Count = 0 Then
            ' Проверяем, является ли текст ячейки email-адресом
            isEmail = regEx.Test(cell.Value)
            
            If isEmail Then
                ' Удаляем гиперссылку, но сохраняем текст
                cell.Hyperlinks.Delete
            End If
        End If
    Next cell
    
    Application.EnableEvents = True
End Sub

Sub RemoveEmailHyperlinksFromAllSheets()
    Dim ws As Worksheet
    Dim cell As Range
    Dim emailPattern As String
    Dim regEx As Object
    Dim isEmail As Boolean
    
    ' Регулярное выражение для email
    emailPattern = "\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,}\b"
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = emailPattern
    regEx.IgnoreCase = True
    regEx.Global = True
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        For Each cell In ws.UsedRange
            If Not cell.Hyperlinks.Count = 0 Then
                isEmail = regEx.Test(cell.Value)
                
                If isEmail Then
                    cell.Hyperlinks.Delete
                End If
            End If
        Next cell
    Next ws
    
    Application.ScreenUpdating = True
    MsgBox "Обработка завершена!", vbInformation
End Sub