Export Block of Emails and Format to New Word doc

[ca1358]

I have Word 2003

I am trying to take a block of Emails in word and put them into new Word
Document Format, so then I can Export to Excel and have each Email address in
a cell. I found this code, that I thought would take the block emails put
into new Word doc and Format. I have never programed in Word, and I am just
learning in Excel and Access.


It stops at this line- runtime error 9 subscript out range.
For i = 1 To UBound(HyperlinkArray()) ' Looping through our array

Any help would greatly be appreciated.

'//////////////////////////////////
Option Explicit

Option Base 1
Dim HyperlinkArray() ' Dimension array to contain hyperlinks
Public Sub Main()
Dim btn
Dim pos
Dim pos2
Dim mytemp
Dim i

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
On Error GoTo BYE
Dim Count As Integer
Count = 0
btn = MsgBox("This macro will copy the hyperlinks from the current." &
vbCrLf & _
" document into a new document." & vbCrLf & vbCrLf & _
" Do you WISH TO PROCEED?", vbYesNo + vbQuestion, _
" Startup Message")
If btn = vbNo Then Exit Sub
Selection.HomeKey Unit:=wdStory ' Go to the top of the document
OUTERLOOP:
With Selection.Find
..Text = "<a href" ' Find the start of the hyperlink
..Replacement.Text = ""
..MatchWildcards = False
..Format = False
..Wrap = wdFindStop
..Forward = True
End With
Selection.Find.Execute
If Selection.Find.Found Then
Selection.ExtendMode = True ' Set extension mode to true
With Selection.Find
..Text = ">" ' Finding the end of the hyperlink.
..Replacement.Text = ""
..MatchWildcards = False
..Format = False
..Wrap = wdFindStop
..Forward = True
End With
Selection.Find.Execute
Selection.ExtendMode = False ' Turn the extension mode off
pos = InStr(Selection.Text, Chr(34))
pos2 = InStr(pos + 1, Selection.Text, Chr(34))
mytemp = Mid(Selection.Text, pos + 1, pos2 - (pos + 1))
Count = Count + 1
ReDim Preserve HyperlinkArray(Count) ' Dynamically resizing the array
HyperlinkArray(Count) = mytemp
Selection.Start = Selection.End
GoTo OUTERLOOP
Else
GoTo ARRAY_FEED
End If
ARRAY_FEED:
Documents.Add Template:="", NewTemplate:=False ' Adding a new document
For i = 1 To UBound(HyperlinkArray()) ' Looping through our array
Selection.InsertAfter Text:=HyperlinkArray(i) & Chr(13) ' Inserting the
hyperlinks
Selection.Start = Selection.End
Next
BYE:
Selection.ExtendMode = False
Selection.HomeKey Unit:=wdStory ' Returning to the top of the document.
btn = MsgBox("There were" & Str(Count) & " hyperlinks extracted to the 2nd
document.", _
vbOKOnly + vbInformation, _
" Final Results")
End Sub

 

[Shauna Kelly]

Hi

To be honest, this is pretty messy code, and it will be difficult to learn
from it.

When you say you have a "block of emails" I'm assuming you mean you have
some email *addresses* in a Word document, and you want to put the addresses
into an Excel file?

Let's look at a macro solutions first: Is this just one big block of text?
If so, you may be able to simply copy and paste from Word into Excel. In
Excel, you may be able to use Data > Text to Columns to split out the
addresses into separate cells.

If it's not just one big block of text, then you could use something like
the following. This will copy all email addresses into a new Excel
workbook..

Before you run this code, you will need to add a reference to the Excel
library. To do that, in the Visual Basic Editor do Tools > References. Tick
the entry named "Microsoft Excel xx Object Library" where xx is your version
of Excel.


Sub CopyEmailAddressesToExcel()

Dim appXL As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim oDoc As Word.Document
Dim oHL As Word.Hyperlink
Dim nRowCounter As Long
Dim sAddress As String

'Get a reference to the active Word document
Set oDoc = Word.ActiveDocument

'Make sure we have some hyperlinks in the Word document
If oDoc.Hyperlinks.Count = 0 Then
MsgBox "There are no hyperlinks in this document"
Else

'Open up Excel, if it's not already open
On Error Resume Next
Set appXL = GetObject(, "Excel.application")
On Error GoTo 0

If appXL Is Nothing Then
Set appXL = CreateObject("Excel.application")
appXL.Visible = True
End If

'Create a new workbook in Excel
Set wkb = appXL.Workbooks.Add

'Get a reference to the first worksheet
Set wks = wkb.Worksheets(1)

'Copy each hyperlink into the Excel file
nRowCounter = 1
For Each oHL In oDoc.Hyperlinks

sAddress = oHL.Address
If sAddress Like "mailto:*" Then
'this is an email address, so we'll copy it

'Strip out the "mailto:" text
sAddress = Replace(sAddress, "mailto:", "")

'Copy the address into Excel
wks.Range("A" & CStr(nRowCounter)).Value = sAddress

'Next time we'll go to the next row in Excel
nRowCounter = nRowCounter + 1
End If

Next oHL

'View the Excel workbook
wkb.Activate
wks.Activate

End If

End Sub



Hope this helps.

Shauna Kelly. Microsoft MVP.
http://www.shaunakelly.com/word