Help modify code to split & save document at section breaks

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 »

I understand that, but the document does not consist of ordinary paragraphs. Most lines of text are in frames, and the piece of text that is in Frame #10 in one part is in Frame #11 in another part, so there is no consistent way of finding out which frame contains the name of the trade union.
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,

Since the doc file is large, I remove the part of the document before uploading. I think that is why the format has changed. Re-update the file and it works for Frame #10.

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_Thirdparty_Letters_pdf()
    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlWsh As Object
    Dim xlRng As Object
    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 sTotal As String
    Dim sDirectory As String

    On Error Resume Next
    Set xlApp = GetObject(Class:="Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject(Class:="Excel.Application")
    End If
    On Error GoTo 0

    ' Add path to workbook if necessary
    Set xlWbk = xlApp.Workbooks.Open("Thirdparty Remitance.xlsm")
    Set xlWsh = xlWbk.Worksheets(1)
    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 PDF'''
            sText = docNew.Frames(10).Range.Text
            sDirectory = "C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Letters\"

            sTotal = docNew.Frames(21).Range.Text
            Set xlRng = xlWsh.Range("F:F").Find(What:=sText, LookAt:=1, MatchCase:=False)
            If Not xlRng Is Nothing Then
               xlRng.Offset(0, 1).Value = Val(sTotal)
            End If

            '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 PDF'''
    sText = docNew.Frames(10).Range.Text

    sTotal = docNew.Frames(21).Range.Text
    Set xlRng = xlWsh.Range("F:F").Find(What:=sText, LookAt:=1, MatchCase:=False)
    If Not xlRng Is Nothing Then
        xlRng.Offset(0, 1).Value = Val(sTotal)
    End If

    docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
    docNew.Close SaveChanges:=False ''close the new document'''

    xlWbk.Close SaveChanges:=True
End Sub
Regards,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

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

Post by macropod »

Seems there's a lot of wheel reinventing going on here.

For documents being created via mailmerge, see Send Mailmerge Output to Individual Files and Run a Mailmerge from Excel, Sending the Output to Individual Files in the Mailmerge Tips and Tricks page at: https://www.msofficeforums.com/mail-mer ... ricks.html. The code there shows how to go about producing the individual documents from the mailmerge itself, without having to split the output afterwards.

Similarly, for existing documents that might have been generated by a mailmerge, see Split Merged Output to Separate Documents on the same page. Such documents don't necessarily have to have been produced by a mailmerge. What the code there allows for - unlike most document splitters - is for the existence of multiple Sections per output document to be extracted from the input document.
Paul Edstein
[Fmr MS MVP - Word]

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 document being discussed in recent replies in this thread is horrible - it appears to be some kind of report that has been converted to PDF and then converted into Word. The result consists of lots of frames...
Regards,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

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

Post by macropod »

Here's a macro I wrote some years ago for cleaning up such documents.

Code: Select all

Sub EraseTextBoxes()
Dim RngDoc As Range, RngShp As Range, i As Long
With ActiveDocument
  For i = .Shapes.Count To 1 Step -1
    With .Shapes(i)
      If .Type = msoTextBox Then
        Set RngShp = .TextFrame.TextRange
        RngShp.End = RngShp.End - 1
        Set RngDoc = .Anchor
        RngDoc.Collapse wdCollapseEnd
        RngDoc.FormattedText = RngShp.FormattedText
        .Delete
      End If
    End With
  Next
End With
End Sub
Basically, it simply relocates the content to wherever the shapes where anchored. It seemed to work OK on that occasion. Maybe it will help here, too. Whether it positions the output correctly depends on where the textboxes are anchored; if the anchor positions are unrelated to the textbox locations, one will end up with a dog's breakfast. Even when that’s not the case, the document will probably still also end up with each line as its own paragraph. To clean up such content, see: https://www.msofficeforums.com/word/298 ... mails.html.
Paul Edstein
[Fmr MS MVP - Word]

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 »

Hi Paul, that macro doesn't help here, since the document consists of frames instead of text boxes. Since a Frame doesn't have an anchor, I can't adapt the code for frames.
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,

I tried & worked correctly, thanks, Hans. But you defined the grand total to Frames (21) ( sTotal = docNew.Frames(21).Range.Text) and it works for one page. Some files consist of several pages, and the last page includes the Grand Total.

Otherwise, when a new union name met creating files that are not in the range (Set xlRng = xlWsh.Range("F:F").Find(What:=sText, LookAt:=1, MatchCase:=False), it can be displayed by a message.

Thanks,

Regarding,

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 »

But you defined the grand total to Frames (21) ( sTotal = docNew.Frames(21).Range.Text) and it works for one page. Some files consist of several pages, and the last page includes the Grand Total.
Once again - the document is inconsistent. I cannot solve that.
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,

Thanks for your help.

regarding,

priyantha

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

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

Post by macropod »

You would probably do better to work with the original PDF and parse its data directly into Excel or to a text file that can be imported into Excel as a CSV file. For an idea of what can be done, see:
https://www.msofficeforums.com/excel-pr ... excel.html
https://www.msofficeforums.com/excel-pr ... -file.html
Paul Edstein
[Fmr MS MVP - Word]

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 Paul Edstein,

Thanks, I'll see.

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 Hans,

My problem above still could not be solved. I hope your help again. Can I find the index number of a frame (Eg. Frame(20)) that included a specific word (Like Gand total). If it can be found, is there a possibility to get the grand total Value to a variable by adding a specific value to that value?

Thanks,


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 »

Try this:

Code: Select all

Sub Split_Thirdparty_Letters_pdf()
    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlWsh As Object
    Dim xlRng As Object
    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 sTotal As String
    Dim sDirectory As String
    Dim i As Long

    On Error Resume Next
    Set xlApp = GetObject(Class:="Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject(Class:="Excel.Application")
    End If
    On Error GoTo 0

    sDirectory = "C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Letters\"
    ' Add path to workbook if necessary
    Set xlWbk = xlApp.Workbooks.Open("Thirdparty Remitance.xlsm")
    Set xlWsh = xlWbk.Worksheets(1)
    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 PDF'''
            sText = docNew.Frames(10).Range.Text

            For i = 1 To docNew.Frames.Count
                If docNew.Frames(i).Range.Text = "Grand  Total" Then
                    sTotal = docNew.Frames(i + 1).Range.Text
                    Exit For
                End If
            Next i
            Set xlRng = xlWsh.Range("F:F").Find(What:=sText, LookAt:=1, MatchCase:=False)
            If Not xlRng Is Nothing Then
               xlRng.Offset(0, 1).Value = Val(sTotal)
            End If

            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 PDF'''
    sText = docNew.Frames(10).Range.Text

    For i = 1 To docNew.Frames.Count
        If docNew.Frames(i).Range.Text = "Grand  Total" Then
            sTotal = docNew.Frames(i + 1).Range.Text
            Exit For
        End If
    Next i
    Set xlRng = xlWsh.Range("F:F").Find(What:=sText, LookAt:=1, MatchCase:=False)
    If Not xlRng Is Nothing Then
        xlRng.Offset(0, 1).Value = Val(sTotal)
    End If

    docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
    docNew.Close SaveChanges:=False ''close the new document'''

    xlWbk.Close SaveChanges:=True
End Sub
Regards,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

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

Post by macropod »

Cross-posted at: https://www.msofficeforums.com/word-vba ... g-vba.html
Please read Eileen's Lounge's policy on Cross-Posting in item 9 of the rules: http://www.eileenslounge.com/viewtopic.php?f=11&t=488
Paul Edstein
[Fmr MS MVP - Word]

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 Paul Edstein,

Actually I was not aware of that. I apologize to all of you in the forum.

Regading

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 Hans,

Your code is working corecly. Thank you very much for your time and knowledge to make my work easier.

Thanks,

Priyantha