Split Word file and save as with custom titles - Macro

[minunel]

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.

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

[minunel]

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.