VBA code to run macro across all documents in folder

rmk911 · #1 04-04-2018, 05:51 PM

Hi there

This is a 3 part question. Also, FYI, I'm completely new to VBA, and am teaching myself as I go on, so all the code below is things I've found and pieced together from the internet.

Note: Part 3 is what I'm really after, and Parts 1+2 splits this up, assuming that Part 3 can't be achieved.

Part 1
I am trying to identify strings of text, whether they be in tables, footnotes, or in the paragraphs in a document, and convert them to a hyperlink. The code I have to do this is as follows:

Sub ConvertHyperlink()

'Set up search
With Selection.Find
.ClearFormatting
.Text = "([A-Za-z0-9]{1,5}).([0-9]{1,5}).([0-9]{1,5}).([0-9_]{1,})"
.Forward = True
.Wrap = wdFindAsk
.MatchWildcards = True
End With

' Find next instance of Pattern "([A-Za-z0-9]{1,5}).([0-9]{1,5}).([0-9]{1,5}).([0-9_]{1,})"
Selection.Find.Execute

' Replace it with a hyperlink
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="Documents/" & Selection.Text, _
TextToDisplay:=Selection.Text

End Sub

This works, except it stops after the first one, and I need to hold down F5 to make it keep going.

Goal 1: I want to make this code execute until it reaches the end of the document.

Part 2
Keeping the above in mind, I want to execute this code across all word documents in a folder.

Goal 2: I want the code in Part 1 to run until it reaches the end of the first document, and then goes on to repeat the same process for every document in a specified folder, such as "E:\Folder".

Part 3
My ultimate goal is to find and replace all strings of text, and convert them to a corresponding hyperlink, depending on the string.

For example, string1 should point to www.google.com, so I was planning on first running the vba code outlined in Parts 1 and 2 to convert the string to a hyperlink, and then I have another set of code to then convert this hyperlink to its corresponding website, as per a table which lists what the string is, and what its corresponding website should be.

The code I have for this is:

Sub ReplaceFromTableList()
' from Doug Robbins, Word MVP, Microsoft forums, Feb 2015, based on another macro written by Graham Mayor, Aug 2010
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim sFname As String
'Change the path in the line below to reflect the name and path of the table document
sFname = "E:\Folder\TABLE.docx"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
For i = 1 To oTable.Rows.Count
Set oRng = oDoc.Range
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
Set rReplacement = oTable.Cell(i, 2).Range
rReplacement.End = rReplacement.End - 1
Selection.HomeKey wdStory
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Text = rFindText.Text
.Replacement.Text = rReplacement.Text
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next i
oChanges.Close wdDoNotSaveChanges

End Sub

Here, E:\Folder\TABLE.docx is the document containing the table.

Goal 3: To convert strings to hyperlinks, depending on a table located in a word document showing the string to be converted, and what the hyperlink should be. This code should run until the end of the document, for all documents in the folder.

Any help, even if it just for the first part, is much appreciated.

Thanks
rmk911

macropod · #2 04-04-2018, 06:58 PM

Try running the following macro from the document containing your Find/Replace table. The code starts on row 2 (to allow for a header row) and assumes column 2 in the table contains the hyperlinks formatted as you want them to appear in the documents.

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, r As Long, strFnd As String
Dim DocTgt As Document, FRDoc As Document, wdDoc As Document, RngStry As Range, RngHlnk As Range
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set FRDoc = ActiveDocument
strDocNm = FRDoc.FullName
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set DocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With DocTgt
      'Process each row from the F/R Table
      For r = 2 To FRDoc.Tables(1).Rows.Count
        strFnd = Split(FRDoc.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
        Set RngHlnk = FRDoc.Tables(1).Cell(r, 2).Range.Hyperlinks(1).Range
        For Each RngStry In .StoryRanges
          With RngStry
            With .Find
              .Text = strFnd
              .Execute
            End With
            Do While .Find.Found
              .FormattedText = RngHlnk.FormattedText
              .Collapse wdCollapseEnd
              .Find.Execute
            Loop
          End With
        Next
      Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = 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

rmk911 · #3 04-05-2018, 12:50 AM

Cheers Paul \ macropod

However, when I run it, the folder is selected, and I get the following run-time error:

'5941'
The requested member of the collection does not exist.

To confirm; the documents in the folder are .doc, and I am running the macro from the document that contains the find/replace table.

Any idea as to what I should do next?

Thanks
rmk911

macropod · #4 04-05-2018, 04:12 AM

Without actually seeing the document you're running the code from, it can be difficult for anyone to diagnose the issue. Can you attach that document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

rmk911 · #5 04-05-2018, 04:37 PM

Thanks macropod

The files are attached. Table.docx is the table for the find/replace, and Test.docx is a sample document containing the strings to be hyperlinked.

macropod · #6 04-05-2018, 05:43 PM

Your Table.docx (which you'd need to save in the docm format to retain the macro) doesn't have hyperlinks in column 2 - just plain text URLs. As described in post #2, the macro:

Quote:

assumes column 2 in the table contains the hyperlinks formatted as you want them to appear in the documents.

That allows you to have actual hyperlinks with both display text and hover text, rather than just unformatted URLs.

rmk911 · #7 04-05-2018, 07:16 PM

Got it; thanks!

Is there any way I can watch the progress of the macro while it runs (like watching it open up the documents, going through and replacing the text)? I want to make sure for example, if I leave it overnight, that it is running.

Cheers
rmk911

macropod · #8 04-05-2018, 08:58 PM

In that case, try running the following macro from the document containing your Find/Replace table. The code starts on row 2 (to allow for a header row) and assumes column 1 contains the strings to find and column 2 contains the strings to replace them with.

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, r As Long, strFnd As String
Dim DocTgt As Document, FRDoc As Document, wdDoc As Document, RngStry As Range, strLnk As String
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set FRDoc = ActiveDocument
strDocNm = FRDoc.FullName
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set DocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With DocTgt
      'Process each row from the F/R Table
      For r = 2 To FRDoc.Tables(1).Rows.Count
        strFnd = Split(FRDoc.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
        strLnk = Split(FRDoc.Tables(1).Cell(r, 2).Range.Text, vbCr)(0)
        For Each RngStry In .StoryRanges
          With RngStry
            With .Find
              .Text = strFnd
              .Execute
            End With
            Do While .Find.Found
              .Hyperlinks.Add Anchor:=.Duplicate, Address:=strLnk, TextToDisplay:=strFnd
              .Collapse wdCollapseEnd
              .Find.Execute
            Loop
          End With
        Next
      Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = 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

rmk911 · #9 04-14-2018, 06:55 AM

Cheers mate.

It seems now that the macro stops at the end of the first document - I then need to open the document (which doesn't display anything when opened), save it, and then move it out of the folder, and then restart the macro, so that it moves onto the next document.

The error is the same as before; being '5941' - The requested member of the collection does not exist.

To confirm, the macro runs successfully, but stops at the first document.

macropod · #10 04-14-2018, 02:32 PM

That's a pretty clear indication that the table in the document you're running the macro from has a row with only one cell and/or that one of those cells is empty.

rmk911 · #11 04-25-2018, 12:54 AM

Thanks Macropod - got there in the end.

After more than a week of running the macro, I now try to launch the macro, using the exact same steps as before, and am instantly met with the 'microsoft office word has stopped working' error message.

I haven't changed anything, and I even uninstalled and repaired microsoft office. I also thought it may have been too large a document, so I ran it on some test data, with one row, and still got the same error.

Any help/ideas is appreciated.

Thanks
rmk911

macropod · #12 04-25-2018, 02:38 PM

There is nothing about the macro itself that would cause that behaviour. Perhaps the document you're running it from has acquired some of corruption. Corrupt documents can often be 'repaired' by inserting a new, empty, paragraph at the very end, copying everything except that new paragraph to a new document based on the same template (macros, userforms, headers & footers may need to be copied separately), closing the old document and saving the new one over it.

Similarly, corrupt tables (which the above process won't repair) can often be 'repaired' by:
• converting the tables to text and back again;
• cutting & pasting them to another document that you save the document in RTF format, which you then close then re-open before copying them back to the source document; or
• saving the document in RTF format, closing the document then re-opening it and re-saving in the doc(x) format.
Do note that some forms of table corruption can only be repaired by the first method.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA Code to copy file to folder and keep the original.	staicumihai	Word VBA	3	10-31-2016 03:07 AM
VBA macro code to remove BMP, text and seal from documents	mach_9	Word VBA	5	09-28-2016 03:19 PM
How to open Documents folder directly from CTRL+O of Open folder on QAT	scvjudy	Word	2	08-11-2014 10:58 PM
Office 2010 Can't Open Or Save Documents in My Documents Folder	trippb	Office	1	07-12-2013 07:29 AM
Macro code should find inv no in folder and send attachhed mail.	visha_1984	Outlook	0	01-30-2013 05:08 AM