Search and return messy spreadsheet for emails

[Killerboy]

Hi!


I have a large (6000+ rows) spreadsheet which is a mess. Its just copy/paste of dozens of different spreadsheets, containing customer information from several different stores.


Goal
My objective is to retrieve all the customer emails from the spreadsheet so we can import it to our newsletter list.


Problem
As the data comes from different vendors, the column for the customers email is varied. For example, from row 1-20 it may be that the emails are in column B. Then from 21-50 it may be in column E, as these rows are data from a different vendor.


I want to retrieve all the emails to a single column, lets say column A, for easy copy/export.


So I need a function to search the entire spreadsheet for emails, for example every cell containing the @ , and then return it to a new email column.


Any help would be greatly appreciated.

 

[Logit]

.
This macro will search Sheet1 / Cols A:Z / rows 1:6000 looking for the symbol @.

When located, it will copy that contents of that cell and paste on Sheet2, starting at A1 and down.

You will need to edit the sheet names if necessary and you can edit the search range as well if required.

Sub fndEmails()
  Dim rFind         As Range
  Dim sAdr          As String


  With Sheets("Sheet1").Range("A1:Z6000")
    .Select
    Set rFind = .Find(What:="*@*", _
                       After:=.Cells(.Cells.Count), _
                       LookIn:=xlValues, _
                       LookAt:=xlWhole, _
                       SearchOrder:=xlNext, _
                       MatchCase:=True)
    If Not rFind Is Nothing Then
      sAdr = rFind.Address
      Do
        Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).Value = rFind.Value2
        Set rFind = .FindNext(rFind)
      Loop While rFind.Address <> sAdr
    End If
  End With
   Sheets("Sheet1").Range("A1").Select
End Sub