![]() |
|
|
Thread Tools | Display Modes |
#3
|
|||
|
|||
![]() Quote:
Thanks for the reply. If I insert these changes I get an error. It says there was an error with compiling. A Sub or a Function isn't defined. And its marking Sub Main() in yellow. I'll insert my code in here as well so you can see if I made a grave mistake or something. ![]() Code:
Dim FSO As Object, oFolder As Object, StrFolds As String Sub Main() Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long TopLevelFolder = GetFolder StrFolds = vbCr & TopLevelFolder If TopLevelFolder = "" Then Exit Sub If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") End If 'Get the sub-folder structure Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders For Each aFolder In TheFolders RecurseWriteFolderName (aFolder) Next 'Process the documents in each folder For i = 1 To UBound(Split(StrFolds, vbCr)) Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i))) Next End Sub Sub RecurseWriteFolderName(aFolder) Dim SubFolders As Variant, SubFolder As Variant Set SubFolders = FSO.GetFolder(aFolder).SubFolders StrFolds = StrFolds & vbCr & CStr(aFolder) On Error Resume Next For Each SubFolder In SubFolders RecurseWriteFolderName (SubFolder) Next End Sub Sub CombineDocuments(oFolder As String) Application.ScreenUpdating = False Dim strFolder As String, strFile As String, strTgt As String Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter strFolder = oFolder Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName strFile = Dir(strFolder & "\*.doc", vbNormal) While strFile <> "" If strFolder & strFile <> strTgt Then 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 With wdDocTgt ' Save & close the combined document .SaveAs FileName:=strFolder & "Forms.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False ' and/or: .SaveAs FileName:=strFolder & "Forms.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False .Close SaveChanges:=False End With 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 Then I changed these two things: Sub CombineDocuments() to Sub CombineDocuments(oFolder As String) and strFolder = GetFolder: If strFolder = "" Then Exit Sub to strFolder = oFolder |
Tags |
combine, help me, word vba |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
macropod | Word VBA | 0 | 09-04-2019 12:09 AM |
![]() |
jwalke123 | Word | 5 | 08-08-2015 03:27 PM |
Cross-referencing in multiple documents that will combine to make one report | razberri | Word | 1 | 01-20-2014 01:00 AM |
combine multiple documents word starter 2010 | bribelge | Word | 3 | 12-19-2012 09:25 AM |
![]() |
Foxtrot75 | Word | 1 | 03-02-2012 03:31 AM |