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.

 

[edmitchell]

Hi

could you expand on what you mean by ‘merge’? And what type of files are they?

thanks

 

[CNorth]

Sorry, I’m working with Word documents and by merge I mean combine into one (each document on a separate page). I’m comfortable with this, I just can’t figut out how to merge only those with the same numbers in the file name.

 

[Macropod]

See: Combine Multiple Word Documents (msofficeforums.com)

For your purposes, you could change:
If strFolder & strFile <> strTgt Then
to:
If Split(strFile, " ")(0) Like "#.#*" Then
or, if you want files beginning only with the number 1:
If Split(strFile, " ")(0) Like "1.#*" Then
Similarly, to get only files prefixed with 1.4:
If Split(strFile, " ")(0) Like "1.4*" Then

 

[CNorth]

Hi,

Thanks you for your reply. I will look into “like” as I haven’t used it before. I think it may need something else too but I’m not sure. I need the procedure to merge any documents with the same numbers i.e. in the files below I would want the process to recognise there are 2 documents at 1.1 and merge them together to form a new document say “1.New”; leave document 1.2 as there’s only one; and merge the 3 documents for 1.3 together to form a new document say “1.3 NEW”. I’m not sure to what number the files would go up to or how many of each of the same there would be.

File sample
1.1a file
1.1b file
1.2 file
1.3a file
1.3b file
1.3c file
1.4 file etc

 

[Macropod]

There seems to be some scope creep going on here. Your first post mentioned nothing about saving each of the various series of documents with a series-derived name.

Try the following edited version of the code in the link I gave in post #4.

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
    Loop
    i = Split(StrFile, ".")(0)
    If (i <> x) Or (j <> y) Then
      x = i: y = j
      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 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
  StrFile = Dir()
Wend
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

 

[CNorth]

Thank you! I'm getting a 'Loop without Do' so I'll need to look into this - still learning VBA - it's not clicking as quickly as I would like.

 

[Macropod]

My bad. Change 'Loop' to 'Next' In:

    Loop
    i = Split(StrFile, ".")(0)

 

[CNorth]

I managed to spot that myself but now it's saying 'While without Wend'.

 

[Macropod]

After:

      wdDocSrc.Close SaveChanges:=False

insert another:

    End If