I have a macro where I merge all RTF (or doc) files in a folder into one word document and create a Table of Contents. But I am trying to figure how to get it to sort before merging.
So my files are label as:
Output 01 - XXXX.rtf
Output 02 - YYYY.rtf
Output 03 - ZZZZ.rtf
....
Output 09 - AAAA.rtf
So I have created this macro to merge all my RTF files in a folder together. But it seem to merge it out of order. With the code I posted below, it copies in this order: 09,08,07,01,02,03,05,06,04... When I actually want it to copy the file in numerical order, 01,02,03,04,05,06,07,08,09. So what can I add on to this code to get it to do that?
Overall, I am hoping this macro can merge any number of outputs, since depending on the project the number of outputs varies. The first part of the file name is always the same with exception of the numbering (Output XX).
Sub merge()
Dim fich As String
fich = InputBox("Path where the outputs are")
Dim ext As String
ext = InputBox("Filename extension (rtf or doc)")
Dim Totfich As String
Dim Name As Variant
ChDrive (fich)
ChDir (fich)
Totfich = fich & "\"
Name = Dir$(Totfich & "*." & ext)
Do While Name <> ""
Documents.Open FileName:=Name
Selection.WholeStory
Selection.Copy
Documents(2).Activate
Selection.Paste
Documents(1).Activate
ActiveDocument.Close False
Name = Dir()
If Name <> "" Then Selection.InsertBreak Type:=wdSectionBreakNextPage
Loop
Dim Int_Tableau As Integer
Dim Ligne As Integer
For Int_Tableau = 1 To ActiveDocument.Tables.Count
ActiveDocument.Tables(Int_Tableau).Cell(1, 1).Select
Options.DefaultBorderLineWidth = wdLineWidth075pt
With Selection.Cells
If Selection.Style = "wdStyleHeading1" Then
ActiveDocument.Tables(Int_Tableau).Select
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
End If
End With
For Ligne = 1 To ActiveDocument.Tables(Int_Tableau).Rows.Count
If ActiveDocument.Tables(Int_Tableau).Columns.Count = 1 Then
ActiveDocument.Tables(Int_Tableau).Cell(Ligne, 1).Select
With Selection.Cells
If Selection.Style = ActiveDocument.Styles(wdStyleHeading1) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading2) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading3) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading4) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading5) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading6) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading7) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading8) Or Selection.Style = ActiveDocument.Styles(wdStyleHeading9) Then
If Selection.PageSetup.Orientation = wdOrientPortrait Then Selection.Columns.Width = CentimetersToPoints(19.8)
If Selection.PageSetup.Orientation = wdOrientLandscape Then Selection.Columns.Width = CentimetersToPoints(28.5)
End If
End With
End If
Next
Next
Selection.GoTo What:=wdPage, Count:=2
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
With ActiveDocument
.TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=9, IncludePageNumbers:=True, AddedStyles:="", _
UseHyperlinks:=True, HidePageNumbersInWeb:=True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
MsgBox ("Don't forget to check the document and to save it!")
End Sub
Bookmarks