Loop the existing word docs from folder, Pagebreak at the end and paste excel data

[Rajkumar_h]

Hello,

I have around 100 word documents stored in my folder, I need to open each document and find the last page and insert a new blank page and paste the excel data to it. I tried using the below code but getting stuck in Sub ProcessDocument(objWordDoc As Document). Please help..

[/COLOR][COLOR=#333333]Private mobjWordApp As Word.Application[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">'https://stackoverflow.com/questions/831458/excel-vba-to-open-multiple-word-files-in-a-loop
Sub Test()
  ProcessDirectory "\\na1.ofc.loc\dfsusa\homedir\Y921737\home\Desktop\WorkMacro"
End Sub

Property Get WordApp() As Word.Application
  If mobjWordApp Is Nothing Then
    Set mobjWordApp = CreateObject("Word.Application")
    mobjWordApp.Visible = True
  End If
  Set WordApp = mobjWordApp
End Property

Sub CloseWordApp()
  If Not (mobjWordApp Is Nothing) Then
    On Error Resume Next
    mobjWordApp.Quit
    Set mobjWordApp = Nothing
  End If
End Sub

Function GetWordDocument(FileName As String) As Word.Document
    On Error Resume Next
    Set GetWordDocument = WordApp.Documents.Open(FileName)
    If Err.Number = &H80010105 Then
      CloseWordApp
      On Error GoTo 0
      Set GetWordDocument = WordApp.Documents.Open(FileName)
    End If
End Function

Sub ProcessDirectory(PathName As String)
  Dim fso As New FileSystemObject
  Dim objFile As File
  Dim objFolder As Folder
  Dim objWordDoc As Object

  On Error GoTo Err_Handler

  Set objFolder = fso.GetFolder(PathName)
  For Each objFile In objFolder.Files
    If StrComp(Right(objFile.Name, 4), ".doc", vbTextCompare) = 0 Then
        Set objWordDoc = GetWordDocument(objFile.Path)
        ' objWordDoc.Unprotect Password:="testcode" ' Need to check if it has Password?
        ProcessDocument objWordDoc
        objWordDoc.Close 0, 1
        Set objWordDoc = Nothing
      ElseIf StrComp(Right(objFile.Name, 4), ".docx", vbTextCompare) = 1 Then
        Set objWordDoc = GetWordDocument(objFile.Path)
        ' objWordDoc.Unprotect Password:="testcode" ' Need to check if it has Password?
        ProcessDocument objWordDoc
        objWordDoc.Close 0, 1
        Set objWordDoc = Nothing
    End If
  Next

Exit_Handler:
  CloseWordApp
  Exit Sub

Err_Handler:
  MsgBox "Error " & Err.Number & ": " & Err.Description
  Resume Exit_Handler
  'Resume Next ' or as above
End Sub

Sub ProcessDocument(objWordDoc As Document)
'Dim pag As Range
'Dim docMultiple As Document
'Set docMultiple = ActiveDocument
lPageCount = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)  '  Getting stuck here
lPageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)

ActiveDocument.Goto What:=wdGoToPage, Which:=wdGoToNext, Name:=lPageCount
Selection.Find.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.InsertBreak Type:=wdPageBreak

 </code>[COLOR=#333333]End Sub[/COLOR][COLOR=#333333]

Thanks in advance
Rajkumar

 

[shknbk2]

Try using the Selection.EndKey command instead:

Sub ProcessDocument(objWordDoc As Document)
'Dim pag As Range
'Dim docMultiple As Document
'Set docMultiple = ActiveDocument


    Selection.EndKey wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.InsertBreak Type:=wdPageBreak


End Sub

 

[Macropod]

It's not apparent what the Excel range is. Nevertheless you should be able to use something like:

Sub UpdateDocuments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet: Set WkSht = ActiveSheet
strFolder = "\\na1.ofc.loc\dfsusa\homedir\Y921737\home\Desktop\WorkMacro\"
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    .Range.InsertAfter vbCr & Chr(12)
    WkSht.Range("A1:J10").Copy
    .Range.Characters.Last.Paste
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

 

[Rajkumar_h]

Hello Paul,

Your code worked perfectly, thank you so much for your help.!

Cheers,
Rajkumar