For Each group of values in a range, output either the email address or a blank, but not both

[ExcelUserZero]

Hello,

I have searched high and low to answer this and perhaps I am searching for the wrong problem to begin with.

I have a query extract that I am working with. I have to sheets, oSheet and vSheet.

On oSheet is the query output.

In column D is a list of Order Numbers

In column E are text notes from our order entry system.



Like this:

4812965	ITEM COLOR: STANDARD
4812965	ITEM SIZE: MEDIUM BLANK STOCK
4812965	SHIP ASAP
4812965	SHIP FEDEX FREIGHT ON OUR ACCT
4812965	IF QUESTIONS CONTACT CUSTOMER SERVICE
4812965	OR AT XXXXXX@DOMAIN.COM

Every order number in Column D is duplicated for each line of text in column E as shown above.



What I need is to use Excel VBA to output only an the email address in Column E if it exists, and a blank cell if an email is not in the range of cells.



In the below code... I tried extracting the email string into column F and searching that column for the "@" and then output the order number and the email or a blank into vSheet in Column A and B, respectively.

Sub ExtractEmail()

Dim PosAt As Integer, PosBeg As Integer, PosEnd As Integer, AddLen As Integer
Dim i  As Integer, Lrow As Long, myString As String

On Error Resume Next
    Lrow = Cells(Rows.Count, "E").End(xlUp).Row
        For i = 1 To Lrow
            PosAt = InStr(1, Cells(i, 5), "@", vbBinaryCompare)
            PosBeg = InStrRev(Cells(i, 5), " ", PosAt, vbBinaryCompare) + 1
            PosEnd = InStr(PosAt, Cells(i, 5), ".com", vbBinaryCompare)
                If PosEnd = 0 Then
                    PosEnd = Len(Cells(i, 5))
                Else
                    PosEnd = PosEnd - 1
                End If
            AddLen = PosEnd - PosBeg + 1
           
           myString = Cells(i, 5).Value
          
           If InStr(myString, "@") <> 0 Then
          
           Cells(i, 6).Value = Mid(Cells(i, 5), PosBeg, AddLen)

            End If
        Next i
End Sub

Sub moveData()

Dim cell As Range
Dim nRow As Long
Dim LR As Long
Dim cString As String
Dim i As Integer


Application.DisplayAlerts = False


nRow = 2
LR = Sheets(1).Cells(Rows.Count, "F").End(xlUp).row
Sheets("vSheet").Range("A1") = "Job Number"
Sheets("vSheet").Range("B1") = "Assigned CSR"

For Each cell In Sheets("oSheet").Range("F2:F" & LR)
    If InStr(cell, "@") <> 0 Then
        Sheets("vSheet").Cells(nRow, 1).Value = cell.Offset(0, -2).Value
        Sheets("vSheet").Cells(nRow, 2).Value = cell.Value
    Else
          Sheets("vSheet").Cells(nRow, 1).Value = cell.Offset(0, -2).Value
          
       nRow = nRow + 1
   
    End If
Next cell

Application.DisplayAlerts = True


End Sub

This code loops through each cell and therefore I have too many blanks after I remove the duplicates (i.e. order numbers with a blank cell and an email address)



I have also tried creating a hidden sheet and loading the unique job numbers into an array, which I can do, but I cannot figure out how to use that to accomplish my goal.

Sub GetJobNo()

'Get Unique Job Numbers and place them in vSheet Column A
Dim dict As Object
Dim cName As Variant
Dim j As Long
Dim LastRow As Long


    Set dict = CreateObject("Scripting.Dictionary")

    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    cName = ThisWorkbook.Sheets(1).Range("D2:D" & lr)

    For j = 1 To UBound(cName, 1)
        dict(cName(j, 1)) = 1

    Next j
   
      
ThisWorkbook.Sheets("Hidden Sheet").Range("A1") = "Unique Job Numbers"
ThisWorkbook.Sheets("Hidden Sheet").Range("A2").Resize(d.Count) = Application.Transpose(d.Keys)
   

End Sub

These are all separately written subs and are part of a much larger VBA project.

Thank you in advance for whatever help you can provide.