Microsoft Office Forums - View Single Post - [Solved] Import a specific range (bookmarked section) from all Word docs in a selected folder

Greengecko · 06-14-2016, 07:54 AM

I should probably explain a little more. I have a doc with four sections:

PMO PROJECTS
INTERNAL INITIATIVES
OPERATIONS & MAINTENANCE
ISSUES/RISKS

Then there are 30 or so reports that come from staff that have four matching bookmarks corresponding to each of those section headings. What I need the macro to do is first find the "PMO PROJECTS" heading, go down one line, and insert the "PMO" range from the 30 reports into that section. Then I have to search for "INTERNAL INITIATIVES" go down one line, and insert the "INT" range, and so on. Hope that makes sense.

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