How do I mass-extract email addresses out of several word documents at once?

Hi all,

This code works in Word, but what needs to be changed so I can make it work in Excel?

I want to extract emailadresses from excel files and put them in a new excel file or new word file.

Anyone can let me know what has to be changed to this code?

Thanks,

Chip

If you want to get the qualifications and the titles, such as (PhD: Assoc Prof),

Use

            With rng

                .Collapse wdCollapseStart

                .MoveEndUntil Cset:=")", count:=wdForward

                .MoveRight Unit:=wdCharacter, count:=1, Extend:=wdExtend

            End With

in place of

              rng.Collapse wdCollapseStart

              rng.MoveEnd wdWord, 2

If you don't want the qualifications and the titles, use just

            With rng

                .Collapse wdCollapseStart

                .MoveEndUntil Cset:="(", count:=wdForward

             End With

Thank you so much all - especially Graham & Doug,

You are right it is complex since it is not necessarily the first 2 words but it will aelast et the bulk of names ....

John J Doe (PhD; Assoc Prof); Primate evolution ecology, conservation biology, tropical forest ecology, vertebrate-plant

interactions; ******@gfbsd.com

Betty Johnson (PhD 2001; Assoc Prof); Cu evolution, cultural transmission, behavioral ecology, evolutionary theory; E •; ******@gfbsd.com

Teste Names (PhD U 1997; Assoc Prof); Environmental confli( cultural politics of neoliberalism, petropolitics, biopolitics; ******@gfbsd.com

Google A Facebook (PhD 1980; Prof); Discours analysis, sociolinguistics, language and culture, language and gender/sexuali text; ******@gfbsd.com

this is how the data appears mostly....but thanks anyway so much its a good start for me ..didnt realise the hlink could be extended to read the words in the paragraph as well...:)

Try the following modification of Graham's code:

 Sub BatchProcess()

 Dim strFilename As String

 Dim strPath As String

 Dim oDoc As Document

 Dim oNewDoc As Document

 Dim oRng As Range

 Dim hLink As Hyperlink

 Dim fDialog As FileDialog

 Dim rng As Range

 Set oNewDoc = Documents.Add

 Options.AutoFormatReplaceHyperlinks = True

 Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

 With fDialog

     .Title = "Select folder containing the documents and click OK"

     .AllowMultiSelect = False

     .InitialView = msoFileDialogViewList

     If .Show <> -1 Then

         MsgBox "Cancelled By User", , _

                "List Folder Contents"

         Exit Sub

     End If

     strPath = fDialog.SelectedItems.Item(1)

     If Right(strPath, 1) <> "" _

        Then strPath = strPath + ""

 End With

 If Left(strPath, 1) = Chr(34) Then

     strPath = Mid(strPath, 2, Len(strPath) - 2)

 End If

 strFilename = Dir$(strPath & "*.doc?")

 While Len(strFilename) <> 0

     WordBasic.DisableAutoMacros 1

     Set oDoc = Documents.Open(strPath & strFilename)

     oDoc.Range.AutoFormat

     For Each hLink In oDoc.Hyperlinks

         If InStr(1, hLink.Address, "@") Then

            Set rng = hLink.Range.Paragraphs(1).Range

            rng.Collapse wdCollapseStart

            rng.MoveEnd wdWord, 2

             oNewDoc.Range.InsertAfter rng.Text & " - " & hLink.Range & vbCr

         End If

     Next hLink

     oDoc.Close SaveChanges:=wdDoNotSaveChanges

     WordBasic.DisableAutoMacros 0

     strFilename = Dir$()

 Wend

 oNewDoc.Paragraphs.Last.Range.Delete

 oNewDoc.Range.Sort

 oNewDoc.Range.Find.Execute FindText:="(*^13)@", _

                            MatchWildcards:=True, _

                            ReplaceWith:="\1", _

                            Replace:=wdReplaceAll

 End Sub