If a cell in range of cells in Excel 2010 contains specific text, move whole cell text into a different column

Question

I am struggling to find an answer to this one...

Each month I am provided with a spreadsheet full of clients data that is a raw extract from some sort of CRM software and that data is a mess. Some cells are merged, some are not. When you unmerge the whole sheet, you end up with data that is meant for one column randomly spread across 3 columns and mixed with another data, ie email addresses are spread across 3 columns and mixed with postcodes.

What I'd like to be able to do is search for cells within columns S, T and U that contain "@" and move (not copy) the whole email address to column V on the same row.

How can I achieve that?

Answer 1

You can achieve this with the following formula into V1:

=INDEX(S1:U1,MATCH(TRUE,NOT(ISERROR(SEARCH("@",S1:U1))),0))

The formula needs to be entered as array formula, i.e. pressing Ctrl-Shift-Enter.

Answer 2

Press Alt+F11 to open the Visual Basic Editor, and then click Insert, Module. Paste this in. Or, just download the example file here. Then under View/Macros, this movemail() routine will be there. Run it.

I take check, money order, paypal, bitcoin... :-) j/j Enjoy.

Sub moveemail()

Dim ws As Worksheet
Dim thisCell As Range, nextCell As Range, lookAt As Range
Dim foundAt As String, lookFor As String
Dim lastRow As Long
lookFor = "@"
On Error GoTo Err

'get last populated cell
Set ws = Application.ActiveSheet
With ws
    If WorksheetFunction.CountA(Cells) > 0 Then
        lastRow = Cells.Find(what:="*", SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    End If
End With

' go cell by cell looking for @ from row 1 to row 10000
Set lookAt = ActiveSheet.Range("S1:U" & lastRow)
Set thisCell = lookAt.Find(what:=lookFor, LookIn:=xlValues, lookAt:=xlPart, SearchDirection:=xlNext)
    If Not thisCell Is Nothing Then
        Set nextCell = thisCell
        Do
            Set thisCell = lookAt.FindNext(After:=thisCell)
            If Not thisCell Is Nothing Then
                foundAt = thisCell.Address

                            thisCell.Copy Range("V" & thisCell.Row)
                            thisCell.ClearContents
            Else
                Exit Do
            End If
            If thisCell.Address = nextCell.Address Then Exit Do
        Loop
    Else
        'MsgBox SearchString & " not Found"
        Exit Sub
    End If
Err:
    'MsgBox Err.Number
    Exit Sub
End Sub