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

ExcelUserZero

New Member
Joined
Jan 18, 2018
Messages
6
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:



4812965ITEM COLOR: STANDARD
4812965ITEM SIZE: MEDIUM BLANK STOCK
4812965SHIP ASAP
4812965SHIP FEDEX FREIGHT ON OUR ACCT
4812965IF QUESTIONS CONTACT CUSTOMER SERVICE
4812965OR 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.



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))
                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


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



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

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

Watch MrExcel Video

Forum statistics

Threads
1,129,383
Messages
5,635,951
Members
416,889
Latest member
dhegs

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
Top