Need help to copy only email & phone no from word to excel!!

[ramuvkrishna]

Hi

i have folder with 1000+ MS word files from which i want COPY only email id ad Phone number to MS excel.

Help much very appreciated.

Thanks in Advance

[gmayor]

That's all very well but where in the documents are these items to be found?

[ramuvkrishna]

In documents it could in top and some document its the bottom these are different format Resume's/CV's.

[gmayor]

I'm sorry, but VBA isn't magic. It conforms to a rigid set of rules. Any macro would have to know how to find the e-mail address in the document, and as for the phone number, what is the format of that number. When you are dealing with lots of disparate documents, as appears to be the case here, and without access to those documents, locating and extracting the required data is going to be difficult or impossible.

Searching a document generally for e-mail addresses is possible, but what if the documents have more than one such address? Which do you want to record?

Telephone numbers present a bigger problem as different people express them differently, and again what if more than one number in the document is identified as a phone number?

[ramuvkrishna]

thanks for the reply, mostly there would be only one email if it search for email id and 9 digit phones number and copy can help me. is it possible and how?

[macropod]

How about attaching one or more documents to a post with a representative sample of the data you want to process - not only the emails & phone #s, but also whatever other content these documents contain (delete/obfuscate anything sensitive).

[ramuvkrishna]

Hi i have attached the folder with two sample files

[macropod]

Try the following Excel macro:

Sub GetData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  i = i + 1
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        'email address
        .Text = "<[0-9A-ÿ.\-]{1,}\@[0-9A-ÿ\-.]{1,}"
        .Execute
      End With
      If .Find.Found = True Then WkSht.Cells(i, 1).Value = .Text
      With .Find
        'phone #
        .Text = "[+\- 0-9]{10,14}"
        .Execute
      End With
      If .Find.Found = True Then WkSht.Cells(i, 2).Value = .Text
    End With
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function