Get Email Contacts From Text String

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,066
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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
VBA Code:
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
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
You just need to specify the sheet name berfore any range references, eg Sheets("Sheet7").Cells(i,2)

VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
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.

VBA Code:
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
 
Upvote 0
Solution
Its ok, Its fixed and work as it should, not sure why it was not working first time round
 
Upvote 0
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...
Excel Formula:
=TRIM(RIGHT(SUBSTITUTE(LEFT(A1,FIND("@",A1)-1)," ",REPT(" ",99)),99))&MID(A1,FIND("@",A1),FIND(" ",A1&" ",FIND("@",A1))-FIND("@",A1))
 
Upvote 0

Forum statistics

Threads
1,224,830
Messages
6,181,225
Members
453,025
Latest member
Hannah_Pham93

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top