Extract emails from text, Sheet issue

[Sharid]

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.

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

 

[NdNoviceHlp]

Maybe...

.Cells(i, ncol) = email

HTH. Dave

 

[Sharid]

Super work Dave

 

[NdNoviceHlp]

Thanks for posting your outcome. Be safe. Dave