Excel Macro

[Netwrkengeer]

I need a macro that will delete all data except email addresses, the data may be a cell full of text then an email address in the middle of the text. this is what I have... The problem with this macro is it deletes the columns and I need it to delete all data, other then the email address, Also I would like it to delete duplicate email addresses.

[ Sub ExtractAddresses()
Application.ScreenUpdating = False

Range("A65536&quot.Select
ActiveCell.End(xlUp).Select
x = ActiveCell.Offset(1, 0).Address
intCounter = 1

Range("B1&quot.Select

Columns("A:A&quot.Select
Selection.Find(What:="Contact: E-mail ", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
x = ActiveCell.Address
ActiveCell.Offset(0, 1).Value = "%"
x = ActiveCell.Address
Selection.FindNext(After:=ActiveCell).Activate

Do Until ActiveCell.Address = x
ActiveCell.Offset(0, 1).Value = "%"
Selection.FindNext(After:=ActiveCell).Activate
intCounter = intCounter + 1
Loop

Range("B1&quot.Select

Do Until intCounter = 0
If ActiveCell.Value <> &quot;%&quot; Then
ActiveCell.EntireRow.Delete

Else
ActiveCell.Offset(1, 0).Select
intCounter = intCounter - 1
End If
Loop

Columns(&quot;B:B&quot.Select
Selection.Delete
Range(&quot;A1&quot.Select


End Sub ]

Thanks

 

[Zathras]

If this is a one-time data cleanup, you don't need VBA.

1. Assuming your data is in column A, starting in row one, put these formulas/data in A1 thru E1:

A1: 'data Contact: E-mail rstuve@abc.com more data
B1: =FIND("Contact: E-mail ",A1)
C1: =IF(ISERROR(B1),"",MID(A1,B1+16,99))
D1: =IF(C1="","",FIND(" ",C1&" "))
E1: =IF(D1="","%",LEFT(C1,D1-1))

2. Copy the formulas down as far as you have data.
3. Select column E, copy and paste special values.
4. Delete columns A thru D
5. Sort the worksheet
6. Use Data/Filter/Advanced Filter... to extract unique records. (You may need to insert row with a heading first to satisfy Excel's requirements.)
7. Delete the row where the only entry is &quot;%&quot;

If you still need to do this in VBA, please provide a little more details in the way of sample data so it can be tailored for you.

 

[pragmatic]

Here's another way. If the source file is a text file.

(rough psuedo code, bare with me.)

open &quot;c:\sourcefile.txt&quot; for input as #1
open &quot;c:\outputfile.txt&quot; for output as #2
do while not EOF(1)

input #1, strLine

if instr(1,&quot;Contact EMAIL&quot;,vbtextcompare)
' strip out excess data here

write #2,strline

loop

close #1
close #2