Help modify code to split & save document at section breaks

User avatar
Rudi
gamma jay
Posts: 25438
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Help modify code to split & save document at section breaks

Post by Rudi »

Hi,

Attached is a sample document that (in reality will be a few hundred pages long - system generated). The aim is to split at sections, which the code I have below does very effectively, but I need help with two small changes.

1. Each split document must be named (not with SplitDocSample_001) as currently in the code, BUT with the Personnel Number (just the number) in the table at the beginning of the doc. So I need to collect that number only and use in the save statement of the macro. Not sure how to do that?

2. When the section is pasted into a new document, it creates a blank page at the end. The code does delete the last section break, but as you can see, the section break is directly after the last bullet point, so deleting the break deletes the last bullet point too? How can this be avoided.

TIA for the assistance.

Code: Select all

Sub BreakOnSection()
Dim sBaseName As String, sNewFileName As String
Dim lSec As Long, lDocNum As Long
Dim sFilePath As String
Dim doc As Document
    
    'Application.ScreenUpdating = False
    With Application.FileDialog(1)
        .Filters.Clear
        .Filters.Add "Word documents", "*.doc*"
        If .Show Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "No document specified!", vbExclamation
            Exit Sub
        End If
    End With
    On Error GoTo CopyFailed
    
    Documents.Open sFilePath
    Application.Browser.Target = wdBrowseSection
    sBaseName = ActiveDocument.Name

    For lSec = 1 To ActiveDocument.Sections.Count - 1
        'Select and copy the section text to the clipboard.
        ActiveDocument.Bookmarks("\Section").Range.Copy
        'Create a new document to paste text from clipboard.
        Documents.Add
        Selection.Paste
        ' Removes the break that is copied at the end of the section, if any.
        Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
        lDocNum = lDocNum + 1
        sNewFileName = Replace(sBaseName, ".do", "_" & Format(lDocNum, "000") & ".do")
        ActiveDocument.SaveAs ThisDocument.Path & "\" & sNewFileName
        ActiveDocument.Close
        ' Move the selection to the next section in the document.
        Application.Browser.Next
    Next lSec
    
    Documents(sBaseName).Close False
    End

CopyFailed:
    MsgBox "An unexpected error occured during processing!" & vbNewLine & _
    Err.Description, vbExclamation
    'Application.Quit SaveChanges:=wdSaveChanges
    End
End Sub
You do not have the required permissions to view the files attached to this post.
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section bre

Post by HansV »

Try this version:

Code: Select all

Sub BreakOnSection()
    Dim sBaseName As String, sNewFileName As String
    Dim lSec As Long, lDocNum As Long
    Dim sFilePath As String
    Dim doc As Document
    Dim tbl As Table
    Dim sText As String

    With Application.FileDialog(1)
        .Filters.Clear
        .Filters.Add "Word documents", "*.doc*"
        If .Show Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "No document specified!", vbExclamation
            Exit Sub
        End If
    End With
    On Error GoTo CopyFailed

    Application.ScreenUpdating = False
    Documents.Open sFilePath
    Application.Browser.Target = wdBrowseSection
    sBaseName = ActiveDocument.Name

    For lSec = 1 To ActiveDocument.Sections.Count - 1
        'Select and copy the section text to the clipboard.
        ActiveDocument.Bookmarks("\Section").Range.Copy
        'Create a new document to paste text from clipboard.
        Documents.Add
        Selection.Paste
        ' Removes the break that is copied at the end of the section, if any.
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=True
        Selection.Delete
        lDocNum = lDocNum + 1
        Set tbl = ActiveDocument.Tables(1)
        sText = tbl.Cell(3, 2).Range.Text
        sText = Trim(Mid(sText, 18, Len(sText) - 20))
        sNewFileName = sText & ".docx"
        ActiveDocument.SaveAs ThisDocument.Path & "\" & sNewFileName
        ActiveDocument.Close
        ' Move the selection to the next section in the document.
        Application.Browser.Next
    Next lSec

ExitHere:
    On Error Resume Next
    Documents(sBaseName).Close False
    Application.ScreenUpdating = True
    Exit Sub

CopyFailed:
    MsgBox "An unexpected error occured during processing!" & vbNewLine & _
    Err.Description, vbExclamation
    Resume ExitHere
End Sub
Regards,
Hans

User avatar
Rudi
gamma jay
Posts: 25438
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Re: Help modify code to split & save document at section bre

Post by Rudi »

Perfect Hans. TX
Just like the other time...why, even though the screenupdating is off, does Word screen flicker on each open and close of the documents?
Last time you minimized (or hide) the Word app? Any ideas why Word flickers?
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section bre

Post by HansV »

VBA does a reasonable job of not updating the screen if you work within a single document, but apparently it isn't able to prevent screen flicker when documents are being opened/created and closed.
Regards,
Hans

User avatar
Rudi
gamma jay
Posts: 25438
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Re: Help modify code to split & save document at section bre

Post by Rudi »

TX.
Excel seems to handle this better though.
Cheers
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear All,

I received a merged Word file (Generated by System - attached herewith) to send to each union and intend to use the following macro to separate it for each union/Welfare society.

But even though the files are created for each union, there is a blank page at the end of each file. I Hope your help to remove that blank page and save that files in a specific Folder "C:\Users\User\Desktop\New folder".

Code: Select all

Sub Split()
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim lngDocNum As Long
    Dim docOld As Document
    Dim docNew As Document
    
    Set docOld = ActiveDocument
    lngStart = 1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "Grand *^12"
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
            Selection.Collapse Direction:=wdCollapseEnd
            lngEnd = Selection.End
            ' Copy the "section"
            docOld.Range(lngStart, lngEnd).Copy
            'Create a new document to paste text from clipboard.
            Set docNew = Documents.Add
            Selection.Paste          
                     
             ' Save the new document
            lngDocNum = lngDocNum + 1
                           
            docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
            FileFormat:=wdFormatXMLDocument
            docNew.Close
            ' set new start
            lngStart = lngEnd + 1
        Loop
    End With
End Sub
Thanks,
Regarding,

Priyantha.
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section breaks

Post by HansV »

Try this:

Code: Select all

Sub Split()
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim lngDocNum As Long
    Dim docOld As Document
    Dim docNew As Document

    Set docOld = ActiveDocument
    lngStart = 1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "Grand *^12"
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
            Selection.Collapse Direction:=wdCollapseEnd
            lngEnd = Selection.End
            ' Copy the "section"
            docOld.Range(lngStart, lngEnd - 1).Copy
            'Create a new document to paste text from clipboard.
            Set docNew = Documents.Add
            Selection.Paste
             ' Save the new document
            lngDocNum = lngDocNum + 1
            docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
                FileFormat:=wdFormatXMLDocument
            docNew.Close
            ' set new start
            lngStart = lngEnd + 1
        Loop
    End With

    ' Last part
    Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = ActiveDocument.Content.End
    ' Copy the "section"
    docOld.Range(lngStart, lngEnd - 1).Copy
    'Create a new document to paste text from clipboard.
    Set docNew = Documents.Add
    Selection.Paste
     ' Save the new document
    lngDocNum = lngDocNum + 1
    docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
        FileFormat:=wdFormatXMLDocument
    docNew.Close
End Sub
Regards,
Hans

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear HansV,

It is Working Correctly. Thank u sooooooooo much for helping me

Regarding,

Priyantha.

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear HansV,

with Reference to your above code.

I tried to convert each separated doc file as pdf files (Eg. Nidahas Sewaka sangamaya.pdf ...........) using the specific word (Union / Welfare Name) in each separated Word File.

For that, I used,

docNew.ExportAsFixedFormat OutputFileName:="Section_" & lngDocNum & ".pdf", ExportFormat:=17
docNew.Close SaveChanges:=False

Instead of yours Code - docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
FileFormat:=wdFormatXMLDocument
docNew.Close

after this editing, files are created as (Section 01.pdf, Section 02 .pdf ........)
Again I tried as,

Dim Text As String
Dim Directory As String

Text = docNew.Frames(11).Range.Text
Directory = "C:\Users\User\Desktop\New folder\"
docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
docNew.Close SaveChanges:=False

The error message was displayed.

Run-time error '-2147467259 (80004005)':
The directory name isn't valid.

help me,

Thanks

Regarding,

Priyantha





Then it showed an error using the following code

User avatar
StuartR
Administrator
Posts: 12166
Joined: 16 Jan 2010, 15:49
Location: London, Europe

Re: Help modify code to split & save document at section breaks

Post by StuartR »

Is the problem something as simple as
Dim Directory As String
then using sDirectory instead of Directory in your code
?
StuartR


Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Sorry
It should be,
Dim xtext
Dim sdirectory, but same error

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section breaks

Post by HansV »

What is the code you have now?
Regards,
Hans

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dim sText As String
Dim sDirectory As String

sText = docNew.Frames(11).Range.Text
sDirectory = "C:\Users\User\Desktop\New folder\"
docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
docNew.Close SaveChanges:=False

Regardind,

Priyantha

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section breaks

Post by HansV »

Dim Directory As String

should be

Dim sDirectory As String

but that should not cause the "The directory name isn't valid." error.
Are you sure that you replaced User with the real username? And that the desktop of this user contains a folder named New folder?
Regards,
Hans

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear HansV

There is a folder as New on my desktop ("C:\Users\User\Desktop\New folder''). This is the code & doc file (attached herewith) I am using.

Code: Select all

Sub Split_Thirdparty_Letters_pdf()
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim lngDocNum As Long
    Dim docOld As Document
    Dim docNew As Document
    Dim sText As String
    Dim sDirectory As String
    
    Set docOld = ActiveDocument
    lngStart = 1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "Grand *^12"
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
            Selection.Collapse Direction:=wdCollapseEnd
            lngEnd = Selection.End
            ' Copy the "section"
            docOld.Range(lngStart, lngEnd - 1).Copy
            'Create a new document to paste text from clipboard.
            Set docNew = Documents.Add
            Selection.Paste
            lngDocNum = lngDocNum + 1
            
            '''Convert to Word File '''
            'docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
                'FileFormat:=wdFormatXMLDocument
            'docNew.Close
            
            '''Conver to PDF'''
            
            sText = docNew.Frames(10).Range.Text
            sDirectory = "C:\Users\User\Desktop\New folder\"
            
            docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
            docNew.Close SaveChanges:=False ''close the new document'''
                                                      
            ' set new start
            lngStart = lngEnd + 1
        Loop
    End With

    ' Last part
    Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = ActiveDocument.Content.End
    ' Copy the "section"
    docOld.Range(lngStart, lngEnd - 1).Copy
    'Create a new document to paste text from clipboard.
    Set docNew = Documents.Add
    Selection.Paste
     ' Save the new document
    lngDocNum = lngDocNum + 1
    
    '''Convert to Word File '''
    'docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
        'FileFormat:=wdFormatXMLDocument
    'docNew.Close
    
    '''Conver to PDF'''
    docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
    docNew.Close SaveChanges:=False ''close the new document'''
            
End Sub
Thanks

Regarding,
Priyantha
You do not have the required permissions to view the files attached to this post.
Last edited by HansV on 19 Nov 2022, 08:01, edited 1 time in total.
Reason: to add [code] ... [/code] tags around the VBA code.

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section breaks

Post by HansV »

In the second and third document, the text of Frames(10) is

Dear Sir / Madam ,

A / is not allowed in file names.
Regards,
Hans

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear HansV

I understand.

Thanks,

Regarding,
Priyantha

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear All,

with your help (especially HansV), I have split a word file (C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Letters\Thirdparty.doc) into separate pdf files using the following codes. Each pdf file has a unique name and a Grand Total is on the last page of each file. (Eg. Grand total = 2580.00).

All pdf file names are listed in an excel sheet as a summary (C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Remittance.xlsm) There is a column named Amount in front of the Name column (with 07 columns Table).

I will hope to,

01) At the time of creating the pdf file, the Grand Total in that file should go to the Amount column in front of the file Name column in the Excel sheet and this should happen for all files. If a file name is created that is not in the name range of the excel sheet, it should be prompted by a message

02) My code should be executed by clicking the "Split & Convert PDF" Button from Excel.

I looked into this and did not find anything suitable for this, so I am looking forward to your help again.

My Code :

Code: Select all

Sub Split_Thirdparty_Letters_pdf()
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim lngDocNum As Long
    Dim docOld As Document
    Dim docNew As Document
    Dim sText As String
    Dim sDirectory As String
    
    
    Set docOld = ActiveDocument
    lngStart = 1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "Grand *^12"
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
            Selection.Collapse Direction:=wdCollapseEnd
            lngEnd = Selection.End
            ' Copy the "section"
            docOld.Range(lngStart, lngEnd - 1).Copy
            'Create a new document to paste text from clipboard.
            Set docNew = Documents.Add
            Selection.Paste
            lngDocNum = lngDocNum + 1
            
            '''Convert to Word File '''
            'docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
                'FileFormat:=wdFormatXMLDocument
            'docNew.Close
            
            '''Conver to PDF'''
            
            sText = docNew.Frames(10).Range.Text
            sDirectory = "C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Letters\"
                        
            docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
            docNew.Close SaveChanges:=False ''close the new document'''
                                                      
            ' set new start
            lngStart = lngEnd + 1
        Loop
    End With

    ' Last part
    Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = ActiveDocument.Content.End
    ' Copy the "section"
    docOld.Range(lngStart, lngEnd - 1).Copy
    'Create a new document to paste text from clipboard.
    Set docNew = Documents.Add
    Selection.Paste
     ' Save the new document
    lngDocNum = lngDocNum + 1
    
    '''Convert to Word File '''
    'docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
        'FileFormat:=wdFormatXMLDocument
    'docNew.Close
    
    '''Conver to PDF'''
    sText = docNew.Frames(10).Range.Text
    docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
    docNew.Close SaveChanges:=False ''close the new document'''
            
End Sub
Thank,

Regarding,

Priyantha
You do not have the required permissions to view the files attached to this post.
Last edited by Priyantha on 04 Dec 2022, 08:00, edited 1 time in total.

User avatar
HansV
Administrator
Posts: 75720
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Help modify code to split & save document at section breaks

Post by HansV »

The content of the document is inconsistent, I cannot work with it.
Regards,
Hans

Priyantha
Lounger
Posts: 37
Joined: 10 Oct 2022, 02:52

Re: Help modify code to split & save document at section breaks

Post by Priyantha »

Dear Hans,

What do you mean "The content of the document is inconsistent"? The word document contains a description of member fee charges related to the trade union. I want to create a summary related to those trade unions in an excel sheet (with Grand Total belongs to Trade unian) and to execute the macro created for it from the excel sheet.

I hope your kind helf

Thank,

Regarding,

Priyantha