#1
|
|||
|
|||
Split Word file and save as with custom titles - Macro
Hi all,
I got someone to help me build the below MACRO. The MACRO is supposed to split a Word file into smaller files following the below steps: 1. Open dialogue asking user where to save the newly created files 2. Create a Word file for each page form the Master file 3. Each file name will be "Heading 1 - Heading 2"_page.number This seemed to work on the guys machine that helped me with this, but it doesn`t work on my machine. Happy for me to share this with you all just in case it fits any of your use cases. I am also wondering if there is anything in the macro that stops it from working correctly on my machine: it only creates the first file, and then the Master file is closed and macro stops working. Any advice is highly appreciated. Code:
Sub save_pages() Application.ScreenUpdating = False Dim d As Word.Document Dim outputpath As String Dim rgePages As Range Dim headingText As String outputpath = GetFolder() pagecount = ActiveDocument.ComputeStatistics(wdStatisticPages) doclink = ActiveDocument.FullName Set d = ActiveDocument For i = 1 To pagecount If i < pagecount Then Set rgePages = d.Range Set rgePages = rgePages.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1) rgePages.SetRange rgePages.Previous.End, d.Range.End rgePages.Delete End If If i > 1 Then Set rgePages = d.Range Set rgePages = rgePages.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i) rgePages.SetRange d.Range.Start, rgePages.Previous.End rgePages.Delete End If For Each para In d.Paragraphs If para.Style = "Heading 1" Then headingText = para.Range.Text Exit For End If Next para For Each para In d.Paragraphs If para.Style = "Heading 2" Then headingText = headingText & " - " & para.Range.Text Exit For End If Next para headingText = Replace(Trim(headingText), Chr(13), "") ' Remove line breaks headingText = Replace(headingText, Chr(11), "") ' Remove manual line breaks headingText = Replace(headingText, Chr(7), "") ' Remove special characters Debug.Print (outputpath & headingText & "_" & CStr(i) & ".docx") d.SaveAs2 outputpath & "\" & headingText & "_" & CStr(i) & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False d.Close (True) Set d = Documents.Open(doclink) Application.StatusBar = "Task is " & (i / pagecount) * 100 & "% Complete" Next i Application.ScreenUpdating = True End Sub Function GetFolder() As String Dim fldr As FileDialog Dim sItem As String Set fldr = Application.FileDialog(msoFileDialogFolderPicker) With fldr .Title = "Select a Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode sItem = .SelectedItems(1) End With NextCode: GetFolder = sItem Set fldr = Nothing End Function |
#2
|
|||
|
|||
Found out what went wrong with the code - I had to add it as a Module in the Normal side of the VBA panel not Project. And it now Works.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Word VBA - Split Document By Headings - Save File Name As Heading Name | jc491 | Word VBA | 7 | 01-21-2022 11:04 AM |
Split word file into several PDF using the bookmarks as split positions and name | Fixxxer | Word VBA | 7 | 10-08-2018 01:10 AM |
Help with Macro to Save Word File as PDF in Specific Location | ekimisme | Word VBA | 1 | 06-07-2017 10:40 PM |
How do I save a Word file with a macro for distribution? | leemoreau | Word VBA | 3 | 10-04-2013 08:06 AM |
Word Macro: Save file as text with current file name | jabberwocky12 | Word VBA | 2 | 10-22-2010 12:23 PM |