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


New Member
Jan 18, 2018

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:

4812965SHIP ASAP

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.

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

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

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

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

Watch MrExcel Video

Forum statistics

Latest member
moon miner

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
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 "".
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