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.
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Hi

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

thanks
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
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
    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
 
Upvote 0
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.
 
Upvote 0
My bad. Change 'Loop' to 'Next' In:
VBA Code:
    Loop
    i = Split(StrFile, ".")(0)
 
Upvote 0
I managed to spot that myself but now it's saying 'While without Wend'.
 
Upvote 0
After:
VBA Code:
      wdDocSrc.Close SaveChanges:=False
insert another:
VBA Code:
    End If
 
Upvote 0

Forum statistics

Threads
1,213,492
Messages
6,113,967
Members
448,537
Latest member
Et_Cetera

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
Back
Top