So here's a macro I was working on:


So it starts by asking what folder I want to save the PDFs to, and then it copies each section to a new document, uses the line UNDER 'strictly private' as a string for the filename + today's date, and then saves.


However I don't want it to copy each letter new document, but I'm not sure how to achieve this.




Sub PDFBySection()
'Select folder'
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "U:"
.Title = "Select a folder to save to"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With

If sFolder <> "" Then ' if a file was chosen
Selection.HomeKey Unit:=wdStory

Application.Browser.Target = wdBrowseSection

'Copy letter to new document'
For i = 1 To ((ActiveDocument.Sections.Count) - 1)
ActiveDocument.Bookmarks("\Section").Range.Copy
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

'Grabs client name'
Selection.HomeKey Unit:=wdStory

With Selection.Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
.Execute FindText:="Strictly Private"
End With

Selection.MoveDown Unit:=wdLine, Count:=1
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy

'Get current date for filename'
Dim xDate As String
On Error Resume Next
xDate = Format((Year(Now() + 1) Mod 100), "20##") & _
Format((Month(Now() + 1) Mod 100), "0#") & _
Format((Day(Now()) Mod 100), "0#")

'Create a string for file name from line 6 where client's name is'
Dim strTemp As String
Dim MyData As DataObject
Set MyData = New DataObject
MyData.GetFromClipboard

'String to put date first then client name second for file name'
strTemp = xDate & " " & MyData.GetText(1)

'Save as PDF'
ActiveDocument.SaveAs FileName:=(sFolder) & "" & (strTemp) & ".PDF", FileFormat:=wdFormatPDF
ActiveDocument.Close savechanges:=wdDoNotSaveChanges

'Move the selection to the next section in the document
Application.Browser.Next
Next i
End If
End Sub