Tìm 1 ký tự trong nhiều cột, trả kq là cột chứa ký tự đó (1 người xem)

[langtulongquan]

Hi các tiền bối,

Em có 1 bảng excel như file đính kèm

Em muốn tổng hợp email của mỗi dòng này thành 1 cột riêng

Em dùng phương pháp tìm ký tự @ trong các cột, và cột nào chứa ký tự đó sẽ được trả về

Tuy nhiên em không biết dùng công thức như thế nào. Hàm if lồng nhau có trường hợp đúng, có trường hợp sai

Các bác giúp em với ạ

Em cảm ơn nhìu ạ

 

[kuldokk]

Hi các tiền bối,


Em có 1 bảng excel như file đính kèm


Em muốn tổng hợp email của mỗi dòng này thành 1 cột riêng


Em dùng phương pháp tìm ký tự @ trong các cột, và cột nào chứa ký tự đó sẽ được trả về


Tuy nhiên em không biết dùng công thức như thế nào. Hàm if lồng nhau có trường hợp đúng, có trường hợp sai


Các bác giúp em với ạ


Em cảm ơn nhìu ạ

Bạn thử download file về, chọn vùng cần tách email ra và bấm nút, mình để tạm email lấy ra vào cột O, nếu cần bạn có thể đổi. Nếu cần loại bỏ những email trùng nhau thì vào data / Remove Duplicates.

Function ExtractEmailFun(extractStr As String) As String

Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Do While True
    Index1 = VBA.InStr(Index, extractStr, "@")
    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
        Exit For
    End If
Next
getStr = getStr & "@"
For p = Index1 + 1 To Len(extractStr)
    If Mid(extractStr, p, 1) Like CheckStr Then
        getStr = getStr & Mid(extractStr, p, 1)
    Else
        Exit For
End If
Next
Index = Index1 + 1
    If OutStr = "" Then
        OutStr = getStr
    Else
        OutStr = OutStr & Chr(10) & getStr
    End If
Else
Exit Do
End If
Loop
ExtractEmailFun = OutStr
End Function

'===============================

Sub getEmail()
    Dim emailArr() As String
    ReDim emailArr(1 To 1) As String
    Dim email As String


    For Each c In Selection
        If Not IsEmpty(c) Then
            On Error Resume Next
            email = ExtractEmailFun(c.Value)
            If Len(email) > 0 And Not IsNumeric(email) Then
                emailArr(UBound(emailArr)) = email
                ReDim Preserve emailArr(1 To UBound(emailArr) + 1) As String
            End If
        End If
    Next
[O1].Resize(UBound(emailArr), 1) = Application.Transpose(emailArr)
End Sub