Sub ExtractAllEmailsFromSheet()

    Dim ws As Worksheet

    Dim outputSheet As Worksheet

    Dim lastRow As Long

    Dim lastCol As Long

    Dim outputRow As Long

    Dim i As Long, j As Long

    Dim cellValue As Variant

    Dim regex As Object

    Dim matches As Object

    Dim match As Object

    ' Đặt sheet gốc và sheet lưu kết quả

    Set ws = ThisWorkbook.Sheets("Sheet1") ' Thay "Sheet1" bằng tên sheet của bạn

    On Error Resume Next

    Set outputSheet = ThisWorkbook.Sheets("Emails")

    If outputSheet Is Nothing Then

        Set outputSheet = ThisWorkbook.Sheets.Add

        outputSheet.Name = "Emails"

    End If

    On Error GoTo 0

    outputSheet.Cells.Clear ' Xóa dữ liệu cũ trên sheet này

    outputRow = 1 ' Bắt đầu ghi từ dòng đầu tiên

    ' Xác định phạm vi dữ liệu

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' Tạo đối tượng RegEx để kiểm tra email hợp lệ

    Set regex = CreateObject("VBScript.RegExp")

    regex.Pattern = "([A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,})" ' Biểu thức tìm email

    regex.Global = True

    regex.IgnoreCase = True

    ' Duyệt qua từng ô trong phạm vi dữ liệu

    For i = 1 To lastRow

        For j = 1 To lastCol

            cellValue = ws.Cells(i, j).Value

            If Not IsError(cellValue) And VarType(cellValue) = vbString Then

                If regex.Test(cellValue) Then ' Nếu chứa email hợp lệ

                    Set matches = regex.Execute(cellValue)

                    For Each match In matches

                        outputSheet.Cells(outputRow, 1).Value = match.Value ' Lưu từng email

                        outputRow = outputRow + 1

                    Next match

                End If

            End If

        Next j

    Next i

    ' Thông báo kết quả

    If outputRow > 1 Then

        MsgBox "Danh sách email đã được lưu tại sheet 'Emails'."

    Else

        MsgBox "Không tìm thấy email hợp lệ."

    End If

End Sub