Extract e-mail from Excel

Sub ExtractEmails()
    Dim emailColumn As Range
    Dim emailCell As Range
    
    ' Запрос пользователя о выборе столбца для извлечения e-mail
    On Error Resume Next
    Set emailColumn = Application.InputBox("Выберите столбец для извлечения e-mail", Type:=8).EntireColumn
    On Error GoTo 0
    
    ' Проверка наличия выбранного столбца
    If emailColumn Is Nothing Then
        MsgBox "Вы не выбрали столбец. Операция прервана.", vbExclamation
        Exit Sub
    End If
    
    ' Проход по каждой ячейке в столбце с e-mail
    For Each emailCell In emailColumn.Cells
        ' Проверка, содержит ли ячейка текст с e-mail
        If InStr(emailCell.Value, "@") > 0 Then
            ' Извлечение e-mail из ячейки
            Dim extractedEmail As String
            Dim emailParts As Variant
            emailParts = Split(emailCell.Value, " ")
            For Each part In emailParts
                If InStr(part, "@") > 0 Then
                    extractedEmail = part
                    Exit For
                End If
            Next part
            
            ' Запись извлеченного e-mail в соседнюю ячейку
            emailCell.Offset(0, 1).Value = extractedEmail
            
            ' Удаление найденного e-mail из исходной ячейки
            emailCell.Value = Replace(emailCell.Value, extractedEmail, "")
        End If
    Next emailCell
    
    MsgBox "Извлечение e-mail завершено.", vbInformation
End Sub