|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Import a specific range (bookmarked section) from all Word docs in a selected folder
Hello,
I'm not a VBA programmer; I do know a fair amount of javascript. Is there a way that the above script can be modified to import a specific range (bookmarked section) from all Word docs in a selected folder? I'd greatly appreciate any help. Here's my first attempt at it. What I'm trying to do is select all files in the folder selected by the user, then import all files in that folder, selecting the Range (bookmark) "pmo": Option Explicit Sub Importer() Dim myFolder As String Dim myFile As String Dim wdDoc As Document Dim docmFiles As Document Application.ScreenUpdating = False myFolder = openFolder If myFolder = "" Then Exit Sub myFile = Dir(myFolder & "\*.docm", vbNormal) Set wdDoc = ActiveDocument While myFile <> "" With Selection.Find.Text = "pmo" End With Selection.MoveDown Unit:=wdLine, Count:=1 Set docmFiles = Documents.Open(FileName:=myFolder & "\" & myFile, AddToRecentFiles:=False, Visible:=False, ConfirmConversions:=False) wdDoc.Range.InsertAfter docmFiles.Range.Bookmarks.Item("pmo") & vbCr docmFiles.Close SaveChanges:=True myFile = Dir() Wend Set docmFiles = Nothing Set wdDoc = Nothing Application.ScreenUpdating = True End Sub Function openFolder() As String Dim oFolder As Object openFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder( 0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then openFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function Last edited by Greengecko; 06-02-2016 at 09:44 AM. Reason: added VBA script |
#2
|
||||
|
||||
For that, you could use a macro like:
Code:
Sub Import_Bookmarked_Text() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDocSrc As Document, wdDocTgt As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) Set wdDocTgt = ActiveDocument While strFile <> "" If strFolder & "\" & strFile <> wdDocTgt.FullName Then Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("pmo") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("pmo").Range.FormattedText .Close SaveChanges:=False End With strFile = Dir() Wend Set wdDocSrc = Nothing: Set wdDocTgt = 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
|
|||
|
|||
Multiple bookmark ranges
Thanks for that, Paul. Now, if I want to insert a couple more bookmark ranges into the same doc, can I just repeat a section of that code and just change the bookmark? My attempt is below, just repeating the "With" section using another bookmark called "int" (thanks for the tip on code tags):
Code:
Sub Import_Bookmarked_Text() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDocSrc As Document, wdDocTgt As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) Set wdDocTgt = ActiveDocument While strFile <> "" If strFolder & "\" & strFile <> wdDocTgt.FullName Then Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("pmo") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("pmo").Range.FormattedText .Close SaveChanges:=False End With With wdDocSrc If .Bookmarks.Exists("int") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("int").Range.FormattedText .Close SaveChanges:=False End With strFile = Dir() Wend Set wdDocSrc = Nothing: Set wdDocTgt = 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 |
#4
|
||||
|
||||
Yes, you can do that. If there's a lot of bookmarks, I'd probably set up an array of bookmark names and put the With .. End With block into a loop that iterates through the array.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
How do search for a heading like "PMO Initiatives" in my master doc and just insert the bookmark/range contents at the line just below that? The current script seems to just add all the ranges at the end of the doc.
|
#6
|
|||
|
|||
I should probably explain a little more. I have a doc with four sections:
Code:
Sub Import_Bookmarked_Text() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDocSrc As Document, wdDocTgt As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) Set wdDocTgt = ActiveDocument While strFile <> "" If strFolder & "\" & strFile <> wdDocTgt.FullName Then Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("pmo") Then ActiveDocument.ActiveWindow.Selection.Find.Text = "PMO PROJECTS" Selection.Find.Replacement.ClearFormatting Selection.Find.Execute Selection.MoveDown Unit:=wdLine, Count:=1 wdDocTgt.Range.InsertAfter wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("pmo").Range.FormattedText .Close SaveChanges:=False End If End With ActiveDocument.ActiveWindow.Selection.Find.Text = "INTERNAL INITIATIVES" Selection.Find.Execute Selection.MoveDown Unit:=wdLine, Count:=1 Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("int") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("int").Range.FormattedText .Close SaveChanges:=False End If End With ActiveDocument.ActiveWindow.Selection.Find.Text = "OPERATIONS & MAINTENANCE" Selection.Find.Execute Selection.MoveDown Unit:=wdLine, Count:=1 Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("ops") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("ops").Range.FormattedText .Close SaveChanges:=False End If End With ActiveDocument.ActiveWindow.Selection.Find.Text = "ISSUES/RISKS" Selection.Find.Execute Selection.MoveDown Unit:=wdLine, Count:=1 Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocSrc If .Bookmarks.Exists("iss") Then wdDocTgt.Range.InsertAfter vbCr wdDocTgt.Range.Characters.Last.FormattedText = .Bookmarks("iss").Range.FormattedText .Close SaveChanges:=False End If End With End If strFile = Dir() Wend Set wdDocSrc = Nothing: Set wdDocTgt = Nothing Application.ScreenUpdating = True End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to Import range between two string from other document | PRA007 | Word VBA | 1 | 12-18-2015 09:23 PM |
Outlook VBA to move selected email to a public folder | aaroncrt | Outlook | 2 | 10-21-2013 05:11 PM |
Print attachment when it arrive in specific folder with specific subject | visha_1984 | Outlook | 1 | 01-30-2013 10:42 AM |
Returning a specific value when item is selected from a drop-down list | J Press | Excel | 4 | 09-10-2012 06:12 AM |
Printing specific section | dfinch | Word VBA | 2 | 06-09-2011 05:10 AM |