#1
|
|||
|
|||
VBA code to run macro across all documents in folder
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 |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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. |
#6
|
||||
|
||||
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:
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
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 Last edited by rmk911; 04-05-2018 at 08:55 PM. Reason: Solution Found |
#8
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
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. |
#10
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
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 |
#12
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Thread Tools | |
Display Modes | |
|
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 |