Word macro - need to run it from excel...

**gonen** · 10-03-2013, 03:03 PM

Hi

this macro works perfect in Word VBA - it merges all .docx files in a given folder into single file.

can someone suggest how to run this in excel vba ???
how can I specify the new merged filename ?

Sub MergeDocs()
    Dim rng As Range
    Dim MainDoc As Document
    Dim strFile As String
    Const strFolder = "d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\"
    Set MainDoc = Documents.Add
    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set rng = MainDoc.Range
        rng.Collapse wdCollapseEnd
        rng.InsertFile strFolder & strFile
        strFile = Dir$()
    Loop
End Sub

thank you very much !!!!

**patel** · 10-05-2013, 01:29 AM

you can not use some word statements with excel

Sub MergeDocs()
strFolder = "d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\" 
destfile ="d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\mergeall.docx" 
strFile = Dir(strFolder & "*.docx")
If strFile = "" Then Exit Sub
With CreateObject(strFolder & strFile)
  Do
    strFile = Dir
    If strFile = "" Then Exit Do
    FName = strFolder & strFile
    .Content.InsertAfter CreateObject(FName).Content
  Loop
  .saveas2 destfile, 12
  .Close False
End With
End Sub

**gonen** · 10-05-2013, 06:01 AM

Actually I ran some word from excel before...

I am looking for a way to merge all .docx files in a given folder into single .docx file

I need to run it from excel.

10x

**patel** · 10-05-2013, 06:59 AM

did you try my code ?

**gonen** · 10-05-2013, 12:23 PM

I will tomorrow ! thank you !!!!!!

**gonen** · 10-05-2013, 09:54 PM

Hi

Your code cannot work like that as you handle docx files as regular files.

To append docx files we must use word as the triggering object to run the process.

I tried your code. It does the merge but as expected - it lose all word formatting.

thanks !!!

**ZVI** · 10-07-2013, 07:52 PM

Try this:

Sub MergeDocs()
'ZVI:2013-10-08 http://www.vbaexpress.com/forum/showthread.php?47741-Word-macro-need-to-run-it-from-excel
  Const wdCollapseEnd As Long = 0
  Dim objWord As Object, strFile As String, strFolder As String
 
  ' If this workbook is saved in the same folder as the DOCs then use this line:
  strFolder = ThisWorkbook.Path & "\"
  ' Else uncomment the line below and change it appropriately
  'strFolder = "d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\"
 
  ' Get/Create Word Application object
  On Error Resume Next
  Set objWord = GetObject(, "Word.Application")
  If Err <> 0 Then Set objWord = CreateObject("Word.Application")
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Merge DOCs in the new Document
  With objWord.Documents.Add.Range
    strFile = Dir$(strFolder & "*.doc*")
    While Len(strFile)
      .Collapse wdCollapseEnd
      .InsertFile strFolder & strFile
      strFile = Dir$
    Wend
  End With
 
exit_:
 
  objWord.Visible = True
  If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
 
End Sub

**gonen** · 10-07-2013, 09:02 PM

Zvi

This worked very nice but the generated merged doc file lost the original documents formatting.

for example - textboxes are not in the right place
right to left is not there anymore
word table does not look the same

so the process works perfect. it merges - but the results are not looking the same...

I tried a manual process like this :

step 1:
edit the first doc in the folder (not open a new doc)

step 2
add a page break at the bottom of the doc
place the cursor on this new page (on the bottom of the doc)

step 3:
insert >> object >> text from file
I selected the next file (only one file)
insert

results were perfect.
the new doc looked as it should. one document after the other with all formatting ok

so I repeated step 2 and step 3 for all the files in the directory - one after the other (only one doc each time)

can this be automated from within excel ???????

I think the key point here is to edit the first doc in the folder (and not to start from blank doc)

p.s.
when I did the same process (steps 2 and 3) after editing a blank doc - results were not good and it lost the formatting.
when i tried to insert more than one file at the same time in step 3 - results were not good so I inserted only one file at a time.

thank you for your time and help !!!!!!

**ZVI** · 10-07-2013, 10:09 PM

Then may be this:

Sub MergeDocs1()
'ZVI:2013-10-08 http://www.vbaexpress.com/forum/showthread.php?47741-Word-macro-need-to-run-it-from-excel
  Const wdCollapseEnd As Long = 0, wdPageBreak As Long = 7
  Dim objWord As Object, strFile As String, strFile1 As String, strFolder As String
 
  ' If this workbook is saved in the same folder as the DOCs then use this line:
  strFolder = ThisWorkbook.Path & "\"
  ' Else uncomment the line below and change it appropriately
  'strFolder = "d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\"
 
  ' Get/Create Word Application object
  On Error Resume Next
  Set objWord = GetObject(, "Word.Application")
  If Err <> 0 Then Set objWord = CreateObject("Word.Application")
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Find name of the 1st document and save it
  strFile = Dir$(strFolder & "*.doc*")
  strFile1 = strFile
 
  ' Merge documents
  If Len(strFile) Then
    With objWord.Documents.Open(strFolder & strFile, , True).Range
      While Len(strFile)
        If strFile <> strFile1 Then
          With .Characters.Last
            .Collapse wdCollapseEnd
            .InsertBreak wdPageBreak
            .InsertFile strFolder & strFile
          End With
        End If
        strFile = Dir$
      Wend
    End With
  End If
 
exit_:
 
  objWord.Visible = True
  If Err Then MsgBox strFile & vbLf & Err.Description, vbCritical, "Error #" & Err.Number
 
End Sub

**gonen** · 10-07-2013, 11:01 PM

PERFECT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!

this is a perfect word documents merger.

All looks exactly like I printed them in a row.

THANK YOU VERY VERY MUCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

**gonen** · 10-07-2013, 11:18 PM

Could you pls add few lines to the code that will save the merged new file to a new file name (without actually touching the original file) ?

many thanks !!!!!

**snb** · 10-08-2013, 04:03 AM

@ZVI

sub M_snb()
  sn=split(createobject("wscript.shell").exec("cmd /c Dir G:\OF\*.doc /b").stdout.readall,vbcrlf)

  for j=0 to ubound(sn)
    with getobject(sn(j))
      c00=c00 & .content
      .close 0
    end with
  next

  open "G:\OF\together.txt" for output as #1
    print #1,c00
  close #1
End Sub

**gonen** · 10-08-2013, 05:01 AM

Hi snb

I gave your code a quick shot and I got:

Automation error (Error 440)

on

With GetObject(sn(j))

j=0anyway - thanks for your efforts

Zvi got it done (hopefully he will spit the piece of code to write the output into a new filename.

thanks !!!

**patel** · 10-08-2013, 05:10 AM

snb, did you read this post ?

Originally Posted by gonen

I tried your code. It does the merge but as expected - it lose all word formatting.

**ZVI** · 10-08-2013, 02:10 PM

Originally Posted by gonen

Could you pls add few lines to the code that will save the merged new file to a new file name (without actually touching the original file) ?

Sure, use this code:

Sub MergeDocs2()
  'ZVI:2013-10-08 http://www.vbaexpress.com/forum/showthread.php?47741-Word-macro-need-to-run-it-from-excel
  Const DestFile As String = "AllMerged.docx"
  Const wdCollapseEnd As Long = 0, wdPageBreak As Long = 7, wdFormatDocument As Long = 0, wdFormatXMLDocument As Long = 12
  Dim objWord As Object, strFile As String, strFile1 As String, strFolder As String, strDestFile As String
 
  ' If this workbook is saved in the same folder as the DOCs then use this line:
  strFolder = ThisWorkbook.Path & "\"
  ' Else uncomment the line below and change it appropriately
  'strFolder = "d:\aagon\data\Poi\Dropbox\Family\Miki\Envelope_to_send\"
 
  ' Get/Create Word Application object
  On Error Resume Next
  Set objWord = GetObject(, "Word.Application")
  If Err <> 0 Then Set objWord = CreateObject("Word.Application")
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Kill previous result
  strDestFile = DestFile
  If Val(objWord.Version) < 12 Then strDestFile = Left(strDestFile, Len(strDestFile) - 1)
  If Len(Dir(strFolder & strDestFile)) > 0 Then Kill strFolder & strDestFile
 
  ' Find name of the 1st document and save its name
  strFile = Dir$(strFolder & "*.doc*")
  strFile1 = strFile
 
  ' Merge documents
  If Len(strFile) Then
    With objWord.Documents.Open(strFolder & strFile, , True)
      While Len(strFile)
        If strFile <> strFile1 And strFile <> strDestFile Then
          With .Range.Characters.Last
            .Collapse wdCollapseEnd
            .InsertBreak wdPageBreak
            .InsertFile strFolder & strFile
          End With
        End If
        strFile = Dir$
      Wend
      ' Save the result
      .SaveAs strFolder & strDestFile, FileFormat:=IIf(Val(objWord.Version) < 12, wdFormatDocument, wdFormatXMLDocument)
      ' Uncomment the next line to close the resulting document
      '.Close False
    End With
  End If
 
exit_:
 
  objWord.Visible = True
  If Err Then MsgBox strFile & vbLf & Err.Description, vbCritical, "Error #" & Err.Number
 
  ' Release the memory
  Set objWord = Nothing
 
End Sub

**ZVI** · 10-08-2013, 02:24 PM

Originally Posted by snb

@ZVI

sub M_snb()
  sn=split(createobject("wscript.shell").exec("cmd /c Dir G:\OF\*.doc /b").stdout.readall,vbcrlf)
' ...
With getobject(sn(j)) ...

Hi snb,
Thank you, it's really nice + short + fast and I saw it in your posts and in site.
The only disadvantage is a short blinking of a DOS window.
But may be it is because of my not modern PC and a pair of glasses

Vlad

**gonen** · 10-08-2013, 09:45 PM

Hi Zvi

that works perfect. the merged file was created with the new name.

one more point...

say I have a folder with 700 files.
any idea how can I merge them in groups of xx files ?
merging all 700 docs into one created huge file...

for example:
grouping by 3 files will take:

file01 file02 file03 and merged them into group01
file04 file05 file06 and merged them into group02

I guess the files are processed sorted by name - so file01 means the first file, file04 means the fouth file an so on...

that will make the MergeDocs2 Sub accept a parameters of : number of files in group...

thanks for sharing this code. !!!

**snb** · 10-09-2013, 02:16 AM

@ZVI

Nothing wrong with your eyes, glasses nor computer.
The shot blinking is inevitable, but the advantages of this method hugely compensate that minor nuisance.

@gonen

My suggestions are never solutions.
You will have to analyse the suggestions and adapt them.

**gonen** · 10-09-2013, 02:22 AM

sure. thanks !!!!

**ZVI** · 10-10-2013, 06:27 PM

@gonen
Have found this thread is still not solved.

Originally Posted by gonen

I guess the files are processed sorted by name - so file01 means the first file, file04 means the fouth file an so on...

Dir() does not process sorted.
For example, file_01.xls and fileA_02.xls are processed by Dir in this order:
fileA_02.xls
file_01.xls

@snb
For regret, one more issue has been discovered with usage of .stdout.readall
Stdout returns DOS (ASCII) characters, and if the file names are not in English then they are converted by VBA to unicode incorrectly.
Have tested it with Russian names, the additional converting from cp866 codepage solves the problem, but for me the dependency from localizations (who knows their codepages?) is not good.
But with English names it works well.
To avoid blinking I would rather use: CreateObject("WScript.shell").Run "cmd /c Dir /b /ON C:\Temp\MyFolder\*.xls* > C:\Temp\MyFolder\MyDir.tmp" , 0, True
and then read temporary file: s = CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\Temp\MyFolder\MyDir.tmp").ReadAll
with: Kill "C:\Temp\MyFolder\MyDir.tmp"
where /ON provides correct names sorting.

Thread: Word macro - need to run it from excel...

Thread Tools

Display

Word macro - need to run it from excel...

Posting Permissions