Loop through files and merge Word files with same number

[CNorth]

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]

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.

 

[Macropod]

Move:

      x = i: y = j

to before:

      Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)

and after:

Wend

insert:

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]

Sorry if I move

 x = i: y = j

it leaves an 'If' statement empty, similarly moving

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]

No, moving

x = i: y = j

does not "an 'If' statement empty". There is another If test embedded within it...

As for moving:

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]

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

 

[CNorth]

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

Would you mind sharing your code? I could not get it to work, Word just keeps crashing.

 

[Macropod]

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:

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]

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]

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]

Try the revised CombineDocuments macro below, in conjunction with the other subs/functions provided previously. Most of the code is the same as before.

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