VBA Site contains VBA code to create macros in WORD EXCEL ACCESS OUTLOOK

1) Merging to Individual Files

2) Merging to Individual Word Files, but single files will have names taken from datasource

3) Merging to Individual PDF Files, but single files will have names taken from datasource as well

 

 

1) Merging to Individual Files (must be merged to new document)

link to the author: Allen Wyatt

 

Sub BreakOnSection()

    Application.Browser.Target = wdBrowseSection

    For i = 0 To ((ActiveDocument.Sections.Count) - 1)

        On Error GoTo finish:

         ActiveDocument.Bookmarks("\Section").Range.Copy

        Documents.Add

        Selection.Paste

        ChangeFileOpenDirectory "C:\YourFolder\"

        DocNum = DocNum + 1

        ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"

        ActiveDocument.Close

        Application.Browser.Next

    Next i

finish:

    ActiveDocument.Close savechanges:=wdDoNotSaveChanges

End Sub

 

2) Merging to Individual Word Files, but single files will have names taken from datasource

link to the author: Spanky Raymond and Other co-authors: Mr. Raduner & Remou

Sub SaveIndividualWordFiles()

Dim iRec As Integer

Dim docMail As Document

Dim docLetters As Document

Dim savePath As String

Set docMail = ActiveDocument

savePath = ActiveDocument.Path & amp & "\"

docMail.MailMerge.DataSource.ActiveRecord = wdLastRecord

iRec = docMail.MailMerge.DataSource.ActiveRecord

docMail.MailMerge.DataSource.ActiveRecord = wdFirstRecord

For i = 1 To iRec

    With docMail.MailMerge

        .Destination = wdSendToNewDocument

        .SuppressBlankLines = True

        With .DataSource

            .FirstRecord = i

            .LastRecord = i

            sFName = .DataFields("NameOfYourColumn").Value 'give name of your field from data souece, this name will be used to name file

        End With

        .Execute Pause:=False

        Set docLetters = ActiveDocument

    End With

            docLetters.SaveAs FileName:=savePath & amp & sFName

            docLetters.Close False

    docMail.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next

End Sub

 

3) Merging to Individual PDF Files, but single files will have names taken from datasource as well

link to the author: Spanky Raymond and Other co-authors: Mr. Raduner & Remou

Sub SavePdfIndividualFiles()

Dim iRec As Integer

Dim docMail As Document

Dim docLetters As Document

Dim savePath As String

Set docMail = ActiveDocument

savePath = ActiveDocument.Path & amp & "\"

docMail.MailMerge.DataSource.ActiveRecord = wdLastRecord

iRec = docMail.MailMerge.DataSource.ActiveRecord

docMail.MailMerge.DataSource.ActiveRecord = wdFirstRecord

For i = 1 To iRec

    With docMail.MailMerge

        .Destination = wdSendToNewDocument

        .SuppressBlankLines = True

        With .DataSource

            .FirstRecord = i

            .LastRecord = i

                  sFName = .DataFields("NameOfYourColumn").Value 'give name of your field from data souece, this name will be used to name file

        End With

        .Execute Pause:=False

        Set docLetters = ActiveDocument

    End With

    docLetters.ExportAsFixedFormat OutputFileName:= _

        savePath & amp & sFName & amp & ".pdf", ExportFormat:= _

        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _

        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _

        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _

        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _

        BitmapMissingFonts:=True, UseISO19005_1:=False

    docLetters.Close False

    docMail.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next

End Sub

 

 

MERGEFIELDS

Sub test()

Dim oPara As Paragraph

For Each oPara In ActiveDocument.Paragraphs

    If Len(oPara.Range.Text) = 1 Then

      oPara.Range.Delete

    End If

Next

  Dim strFirstWord As String

  Dim strLastWord As String

  Dim objDoc As Document

  Dim objWord As Object

   Set objDoc = ActiveDocument

  strFirstWord = "Procent odp." 'InputBox("Enter the first word:", "First Word")

  strLastWord = "Pytanie nr" 'InputBox("Enter the last word:", "Last Word")

   With Selection

    .HomeKey Unit:=wdStory

    With Selection.Find

      .ClearFormatting

      .Replacement.ClearFormatting

      .Text = strFirstWord & "*" & strLastWord

      .Replacement.Text = strLastWord 'strFirstWord & strLastWord

      .MatchWildcards = True

      .Execute Replace:=wdReplaceAll

    End With

  End With

 

  Set objDoc = Nothing

  Set objWord = Nothing

End Sub

 IF Mergefield

 

 Surpress BlankLInes

 



Dodaj komentarz






Dodaj

© 2013-2024 PRV.pl
Strona została stworzona kreatorem stron w serwisie PRV.pl