Loop through files and merge Word files with same number

CNorth

New Member
Joined
Jan 7, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hi

I’m still learning VBA and would be grateful if someone could point me in the right direction. I would like to loop through files in a folder and merge documents with the same number. The file numbering is shown below, for example I need to merge files 1.4a-d. I will use FSO to access the folder, then InStr to find the position of the space character, then LEFT to extract the leftmost substring (although there may be an easier way to do this?!). However, I’m not sure of the next step, can someone kindly suggest how I go about coding - if the substring matches the next folder substring then do….

1.1 FileName
1.2 FileName
1.3 FileName
1.4a FileName
1.4b FileName
1.4c FileName
1.4d FileName

Thank you. Caroline.
 

CNorth

New Member
Joined
Jan 7, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
I've added an 'End If' before 'Wend' and while it runs, the outcome isn't quite right.

original files are
1.1a
1.1b
1.1c
1.2
1.3a
1.3b
1.3c

after running the procedure the files are
1.1a
1.1b
1.1c
1.2
1.2- Combined (this new document is 1.1a & 1.1b & 1.1c as desired but needs to be named '1.1 - Combined')
1.3a
1.3b
1.3c
1.3 - Combined (which is actually document 1.2 on it's own, the procedure did not combine 1.3a & 1.3b & 1.3c)

the desired files are
1.1a
1.1b
1.1 - Combined (i.e. files 1.1a &1.1b)
1.2
1.3a
1.3b
1.3c
1.3 Combined (i.e. files 1.3a &1.3b & 1.3c)

I really appreciate you're help with and I'm happy to try figure it out if you can point me in the right direction.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,557
Move:
VBA Code:
      x = i: y = j
to before:
VBA Code:
      Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
and after:
VBA Code:
Wend
insert:
VBA Code:
With wdDocTgt
  ' Save & close the combined document
  .SaveAs FileName:=strFolder & "\" & i + j / 10 & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  .Close SaveChanges:=False
End With

Note that, as coded, all the outputs will have a 'Combined' suffix to evidence they've been processed, even if there's only one file in the group.
 

CNorth

New Member
Joined
Jan 7, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Sorry if I move
VBA Code:
 x = i: y = j
it leaves an 'If' statement empty, similarly moving
VBA Code:
With wdDocTgt
  ' Save & close the combined document
  .SaveAs FileName:=strFolder & "\" & i + j / 10 & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  .Close SaveChanges:=False
End With
leave the If Not statement empty.. Moving the surrounding code just stops word responding.
 

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,557
No, moving
VBA Code:
x = i: y = j
does not "an 'If' statement empty". There is another If test embedded within it...

As for moving:
VBA Code:
With wdDocTgt
  ' Save & close the combined document
  .SaveAs FileName:=strFolder & "\" & i + j / 10 & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  .Close SaveChanges:=False
End With
that is not what I said to do - I said to insert those lines at the new location.
 

DrakeHeyman

Spammer
Joined
Feb 9, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
  3. Web

ADVERTISEMENT

I had a similar task, thank you for your help.
 

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,557

ADVERTISEMENT

If you had made all the changes I advised, except for the commented-out lines "'If Not wdDocTgt Is Nothing Then" and "'End If", you would now have:
VBA Code:
Sub CombineDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, StrFile As String, StrTmp As String
Dim i As Long, j As Long, x As Long, y As Long
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
strFolder = GetFolder: If strFolder = "" Then Exit Sub
StrFile = Dir(strFolder & "\*.doc", vbNormal)
While StrFile <> ""
  StrTmp = Split(StrFile, " ")(0)
  If StrTmp Like "#.#*" Then
    StrTmp = Split(StrFile, ".")(1): j = 0
    For i = 1 To Len(StrTmp)
      If Mid(StrTmp, i, 1) Like "[0-9]" Then
        j = j * 10 + Mid(StrTmp, i, 1)
      Else
        Exit For
      End If
    Next
    i = Split(StrFile, ".")(0)
    If (i <> x) Or (j <> y) Then
      If Not wdDocTgt Is Nothing Then
        With wdDocTgt
          ' Save & close the combined document
          .SaveAs FileName:=strFolder & "\" & i + j / 10 & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
      End If
      x = i: y = j
      Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
    Else
      Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
      With wdDocTgt
        .Characters.Last.InsertBefore vbCr
        .Characters.Last.InsertBreak (wdSectionBreakNextPage)
        With .Sections.Last
          For Each HdFt In .Headers
            With HdFt
              .LinkToPrevious = False
              .Range.Text = vbNullString
              .PageNumbers.RestartNumberingAtSection = True
              .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
            End With
          Next
          For Each HdFt In .Footers
            With HdFt
              .LinkToPrevious = False
              .Range.Text = vbNullString
              .PageNumbers.RestartNumberingAtSection = True
              .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
            End With
          Next
        End With
        Call LayoutTransfer(wdDocTgt, wdDocSrc)
        .Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
        With .Sections.Last
          For Each HdFt In .Headers
            With HdFt
              .Range.FormattedText = wdDocSrc.Sections.Last.Headers(.Index).Range.FormattedText
              .Range.Characters.Last.Delete
            End With
          Next
          For Each HdFt In .Footers
            With HdFt
              .Range.FormattedText = wdDocSrc.Sections.Last.Footers(.Index).Range.FormattedText
              .Range.Characters.Last.Delete
            End With
          Next
        End With
      End With
      wdDocSrc.Close SaveChanges:=False
    End If
  End If
  StrFile = Dir()
Wend
'If Not wdDocTgt Is Nothing Then
  With wdDocTgt
    ' Save & close the combined document
    .SaveAs FileName:=strFolder & "\" & i + j / 10 & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .Close SaveChanges:=False
  End With
'End If
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Sub LayoutTransfer(wdDocTgt As Document, wdDocSrc As Document)
Dim sPageHght As Single, sPageWdth As Single
Dim sHeaderDist As Single, sFooterDist As Single
Dim sTMargin As Single, sBMargin As Single
Dim sLMargin As Single, sRMargin As Single
Dim sGutter As Single, sGutterPos As Single
Dim lPaperSize As Long, lGutterStyle As Long
Dim lMirrorMargins As Long, lVerticalAlignment As Long
Dim lScnStart As Long, lScnDir As Long
Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long
Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean
Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean
Dim lOrientation As Long
With wdDocSrc.Sections.Last.PageSetup
  lPaperSize = .PaperSize
  lGutterStyle = .GutterStyle
  lOrientation = .Orientation
  lMirrorMargins = .MirrorMargins
  lScnStart = .SectionStart
  lScnDir = .SectionDirection
  lOddEvenHdFt = .OddAndEvenPagesHeaderFooter
  lDiffFirstHdFt = .DifferentFirstPageHeaderFooter
  lVerticalAlignment = .VerticalAlignment
  sPageHght = .PageHeight
  sPageWdth = .PageWidth
  sTMargin = .TopMargin
  sBMargin = .BottomMargin
  sLMargin = .LeftMargin
  sRMargin = .RightMargin
  sGutter = .Gutter
  sGutterPos = .GutterPos
  sHeaderDist = .HeaderDistance
  sFooterDist = .FooterDistance
  bTwoPagesOnOne = .TwoPagesOnOne
  bBkFldPrnt = .BookFoldPrinting
  bBkFldPrnShts = .BookFoldPrintingSheets
  bBkFldRevPrnt = .BookFoldRevPrinting
End With
With wdDocTgt.Sections.Last.PageSetup
  .GutterStyle = lGutterStyle
  .MirrorMargins = lMirrorMargins
  .SectionStart = lScnStart
  .SectionDirection = lScnDir
  .OddAndEvenPagesHeaderFooter = lOddEvenHdFt
  .DifferentFirstPageHeaderFooter = lDiffFirstHdFt
  .VerticalAlignment = lVerticalAlignment
  .PageHeight = sPageHght
  .PageWidth = sPageWdth
  .TopMargin = sTMargin
  .BottomMargin = sBMargin
  .LeftMargin = sLMargin
  .RightMargin = sRMargin
  .Gutter = sGutter
  .GutterPos = sGutterPos
  .HeaderDistance = sHeaderDist
  .FooterDistance = sFooterDist
  .TwoPagesOnOne = bTwoPagesOnOne
  .BookFoldPrinting = bBkFldPrnt
  .BookFoldPrintingSheets = bBkFldPrnShts
  .BookFoldRevPrinting = bBkFldRevPrnt
  .PaperSize = lPaperSize
  .Orientation = lOrientation
End With
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
With those changes, there is no reason you would end up with "Word just keeps crashing" unless there is some other problem with your system.

Uncommenting the lines mentioned would give an extra level of error-checking, but shouldn't be needed unless you choose a folder with no conforming documents.
 

CNorth

New Member
Joined
Jan 7, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Thank you, I’ll try it out. I have contacted our IT department about Word and I’m waiting for them to investigate so it could be that.
 

CNorth

New Member
Joined
Jan 7, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hi

Unfortunately, the numbering of the new combined file is not quite right. The procedure combines documents 1.1a and 1.1b but the new file name is '1.2 Combined' as opposed to '1.1 Combined' I've used the immediate window to look at the variables as the code runs but I can't see where the error is. Any suggestions would be appreciated.

Thanks

Caroline
 

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,557
Try the revised CombineDocuments macro below, in conjunction with the other subs/functions provided previously. Most of the code is the same as before.
VBA Code:
Sub CombineDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, StrFile As String, StrOld As String, StrNew As String
Dim i As Long, wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
strFolder = GetFolder: If strFolder = "" Then Exit Sub
StrFile = Dir(strFolder & "\*.doc", vbNormal)
While StrFile <> ""
  StrNew = Split(StrFile, " ")(0)
  If StrNew Like "#.#*" Then
    For i = Len(StrNew) To 1 Step -1
      If Not Right(StrNew, 1) Like "[0-9]" Then
        StrNew = Left(StrNew, Len(StrNew) - 1)
      Else
        Exit For
      End If
    Next
  End If
  If wdDocTgt Is Nothing Then
    Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
    StrOld = StrNew
  ElseIf StrOld <> StrNew Then
    With wdDocTgt
      ' Save & close the combined document
      .SaveAs FileName:=strFolder & "\" & StrOld & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
    Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
    StrOld = StrNew
  Else
    Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
    With wdDocTgt
      .Characters.Last.InsertBefore vbCr
      .Characters.Last.InsertBreak (wdSectionBreakNextPage)
      With .Sections.Last
        For Each HdFt In .Headers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
          End With
        Next
      End With
      Call LayoutTransfer(wdDocTgt, wdDocSrc)
      .Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
      With .Sections.Last
        For Each HdFt In .Headers
          With HdFt
            .Range.FormattedText = wdDocSrc.Sections.Last.Headers(.Index).Range.FormattedText
            .Range.Characters.Last.Delete
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .Range.FormattedText = wdDocSrc.Sections.Last.Footers(.Index).Range.FormattedText
            .Range.Characters.Last.Delete
          End With
        Next
      End With
    End With
    wdDocSrc.Close SaveChanges:=False
  End If
  StrFile = Dir()
Wend
If Not wdDocTgt Is Nothing Then
  With wdDocTgt
    ' Save & close the combined document
    .SaveAs FileName:=strFolder & "\" & StrOld & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .Close SaveChanges:=False
  End With
End If
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,130,176
Messages
5,640,614
Members
417,158
Latest member
jimmy1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top