Sharid
Well-known Member
- Joined
- Apr 22, 2007
- Messages
- 1,064
- Office Version
- 2016
- Platform
- Windows
I am using this code to extract staff and supplier emails from text, it works fine, however I have ONE issue that I can't workout
1) I need to be ON the sheet in order for it to work.
I am running it from a userform and it should not matter what sheet i am on, the code should still work. However I have to select the sheet and then run it to get it to work.
1) I need to be ON the sheet in order for it to work.
I am running it from a userform and it should not matter what sheet i am on, the code should still work. However I have to select the sheet and then run it to get it to work.
VBA Code:
ThisWorkbook.Worksheets("EmailPaste").Range("A1").Value = "Your Text"
ThisWorkbook.Worksheets("EmailPaste").Range("B1:Z").Value = "Emails Found"
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("EmailPaste")
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
On Error Resume Next
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