How do I isolate all company addresses ?

[Maverick27]

Attn all Excel Gurus

I have an Excel sheet of 500K Email Addresses.

How do isolate all company addressess eg addresses which DON'T have the following domains ?

@Yahoo ;
@gmail ;
@Hotmail ;
@Live ;
@ymail ;
@msn

Anyone care to share a Excel function or Macro to filter out the company address domains.

Below is a screenshot of the Excel list.

Thanks in Advance.

 

[Fluff]

@mohadin with 500k emails, you could have problems with transpose.

 

[Fluff]

@JEC have you tried transposing 500k rows of data? Also Filter does a partial match, so it will remove something like @Livery.co.uk as well.

 

[Maverick27]

Thanks for the function.

Works fine, although its gonna take some time to copy it across to 500K rows.

 IF(ISNUMBER(SEARCH("@Yahoo",A2)),"Needs to be excluded",IF(ISNUMBER(SEARCH("@Gmail",A2)),"Needs to be excluded",IF(ISNUMBER(SEARCH("@Hotmail",A2)),"Needs to be excluded",IF(ISNUMBER(SEARCH("@Live",A2)),"Needs to be excluded",IF(ISNUMBER(SEARCH("@ymail",A2)),"Needs to be excluded",IF(ISNUMBER(SEARCH("@msn",A2)),"Needs to be excluded","Include"))))))

I think this should work but may potentially be very slow calculating your sheet given the size of the workbook.

There is probably a better approach to this.

 

[Maverick27]

Or

Sub jec()
 With Range("A1", Range("A" & Rows.Count).End(xlUp))
   .AutoFilter 1, Filter(Filter(Filter(Filter(Filter(Filter(Application.Transpose(.Value), "@Yahoo", 0, 1), "@Gmail", 0, 1), "@Hotmail", 0, 1), "@Live", 0, 1), "@ymail", 0, 1), "@msn", 0, 1), 7
 End With
End Sub

Thanks for sharing.

The code works like a charm.

 

[Maverick27]

How about

Sub Maverick()
   Dim Ary As Variant, Nary As Variant, Sp As Variant
   Dim Lst As String
   Dim r As Long, nr As Long
  
   Lst = "|Yahoo|gmail|Hotmail|Live|ymail|msn"
   Ary = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         Sp = Split(Split(Ary(r, 1), "@")(1), ".")(0)
         If InStr(1, Lst, "|" & Sp & "|", vbTextCompare) = 0 Then
            If Not .Exists(Sp) Then
               nr = nr + 1
               Nary(nr, 1) = Sp
               .Add Sp, Nothing
            End If
         End If
      Next r
   End With
   Range("B2").Resize(nr).Value = nr
End Sub

Sorry - the macro code is giving an Error.

 

[Fluff]

On which line?

 

[Maverick27]

How about

Sub test()
    Dim a, b
    Dim i, k
    k = 1
    a = Sheets("sheet1").Cells(2, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 1)
    ReDim b(1 To UBound(a))
    With CreateObject("VBScript.RegExp")
        .Pattern = "@yahoo|@gmail|@hotmail|@live|@ymail|@msn"
        .IgnoreCase = True
        For i = 1 To UBound(a)
            If .test(a(i, 1)) Then
                b(k) = a(i, 1)
                k = k + 1
            End If
        Next
    End With
    Sheets("sheet1").Cells(2, 2).Resize(k - 1) = Application.Transpose(b)
End Sub

Sorry - the code is giving an Error.

 

[JEC]

@Fluff, I tried on 500k rows and it worked. Transposing to a variable could be different than to the worksheet, which will give issues after 16k rows sometimes...

 

[Fluff]

Transposing to a variable could be different than to the worksheet,

If it works, then maybe it is just writing to the sheet that's a problem, I always thought it was the Transpose itself that couldn't handle that much data, but obviously wrong.

 

[Maverick27]

On which line?