Get Email Contacts From Text String

[Sharid]

I have to extract a lot of staff and supply contacts (emails )from a worksheet. I have got this code from here Link but now I am trying to make some changes to it so it pulls from Sheet7. Currently I have the command button On sheet7. However I will be moving it to a userform and Sheet7 may not always be active when it is run. I could be on sheet2 when I click the button.

Problem,
1) How do I get it to work from Sheet7
2) Range to be dynamic and I don't have to input in the range

Command Button Click ()
Dim WorkRng As Range
Dim arr As Variant
Dim CharList As String
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
CheckStr = "[A-Za-z0-9._-]"
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
        extractStr = arr(i, j)
        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
        arr(i, j) = outStr
    Next
Next
WorkRng.Value = arr
End Sub

I was also looking at this, as the range is last row with data, but need to have it checking sheet7. Mr Excel

Dim PosAt As Integer, PosBeg As Integer, PosEnd As Integer, AddLen As Integer
Dim i  As Integer, Lrow As Long
On Error Resume Next
    Lrow = Cells(Rows.Count, "A").End(xlUp).Row
        For i = 2 To Lrow
            PosAt = InStr(1, Cells(i, 2), "@", vbBinaryCompare)
            PosBeg = InStrRev(Cells(i, 2), " ", PosAt, vbBinaryCompare) + 1
            PosEnd = InStr(PosAt, Cells(i, 2), " ", vbBinaryCompare)
                If PosEnd = 0 Then
                    PosEnd = Len(Cells(i, 2))
                Else
                    PosEnd = PosEnd - 1
                End If
            AddLen = PosEnd - PosBeg + 1
            Cells(i, 2).Value = Mid(Cells(i, 2), PosBeg, AddLen)
        Next i

 

[sericom]

You just need to specify the sheet name berfore any range references, eg Sheets("Sheet7").Cells(i,2)

Dim PosAt As Integer, PosBeg As Integer, PosEnd As Integer, AddLen As Integer
Dim i  As Integer, Lrow As Long
On Error Resume Next
    With Sheets("Sheet7")
    Lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To Lrow
            PosAt = InStr(1, .Cells(i, 2), "@", vbBinaryCompare)
            PosBeg = InStrRev(.Cells(i, 2), " ", PosAt, vbBinaryCompare) + 1
            PosEnd = InStr(PosAt, .Cells(i, 2), " ", vbBinaryCompare)
                If PosEnd = 0 Then
                    PosEnd = Len(.Cells(i, 2))
                Else
                    PosEnd = PosEnd - 1
                End If
            AddLen = PosEnd - PosBeg + 1
            .Cells(i, 2).Value = Mid(.Cells(i, 2), PosBeg, AddLen)
        Next i

 

[Sharid]

Sericom

Thanks for your input, I new it was something simple, just could not work it out. The problem with the second code is that I need to have Data in Colum A and B for it to work and then it only extracts the FIRST EMAIL from the text string.

I need it to work from Only having data in column A and to extract all the email contacts NOT just the first email.

 

[Sharid]

Hi

I was able to fix the first part of the code with this Source QZ Grid, However it old extracts the first email found in the cell, if there was more that1 in that cell, it will ignore the rest.

Dim lastrow As Long, i As Long
Dim ncol As Integer, spos As Integer
Dim n As Integer, n1 As Integer, n2 As Integer
Dim searchtxt As String
Dim email As String
With Worksheets("Sheet7")
 lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
 For i = 1 To lastrow
 searchtxt = .Range("A" & i)
 ncol = 2
 spos = 1
 Do
 n = InStr(spos, searchtxt, "@", vbTextCompare)
 If n <> 0 Then
 n1 = InStrRev(searchtxt, " ", n, vbTextCompare)
 n2 = InStr(n, searchtxt, " ", vbTextCompare)
 If n2 = 0 Then n2 = Len(searchtxt) + 1
 email = Trim(Mid(searchtxt, n1, n2 - n1))
 Cells(i, ncol) = email
 ncol = ncol + 1
 spos = n2
 End If
 Loop Until n = 0
 Next i
End With

 

[Sharid]

Its ok, Its fixed and work as it should, not sure why it was not working first time round

 

[Rick Rothstein]

Hi

I was able to fix the first part of the code with this Source QZ Grid, However it old extracts the first email found in the cell, if there was more that1 in that cell, it will ignore the rest.

Assuming the email address is always surrounded by spaces, there is a formula that can be used to find the first email address in the text...

=TRIM(RIGHT(SUBSTITUTE(LEFT(A1,FIND("@",A1)-1)," ",REPT(" ",99)),99))&MID(A1,FIND("@",A1),FIND(" ",A1&" ",FIND("@",A1))-FIND("@",A1))