@JenniferVazquez You have a number of problems with your code.
- You have a number of undeclared variables. This is likely because you haven't put 'Option explicit' as the first line of your module. Always always put option explicit as the first line of any modules or classes you write.
Then always do Debug.Compile before trying to run your code.
In addition to 'Option Explicit' and doing Debug.COmpile, if your company allows you, then install the fantabulous RubberDuck addin and pay close attention to the Code Inspections this Addin can provide.
You haven't actually given a name to your new file . In fact its unlikely that your code will run as given above.
You should really have also provided a sample document against which we could check your code to see if we get the same results as yourself, and also to help us when we write new code or update your code.
I have written some code which I think does what your original code is trying to do. In my code I've split activities into different functions. If I tried harder I could split my code into even more smaller functions but I think you'll see the general idea.
Thank for putting lots of comments in your code, it did make it easier to work out what you are trying to do.
I hope the code below helps you.
Option Explicit
Public Sub Test()
SplitIntoIndividualLetters ActiveDocument
End Sub
Public Sub SplitIntoIndividualLetters(Optional ByRef ipDocument As Word.Document = Nothing)
Dim myCurrentLetterRange As Word.Range
Dim myClientName As String
Set myCurrentLetterRange = GetNextLetterRange(IIf(ipDocument Is Nothing, ActiveDocument, ipDocument))
Do While Not myCurrentLetterRange Is Nothing
myClientName = GetClientname(myCurrentLetterRange.Duplicate)
If Not TrySaveIndividualLetter(myCurrentLetterRange.Duplicate, myClientName) Then
MsgBox "Something went wrong, the letter for " & myClientName & " was not saved", vbOKOnly
Stop
End If
Set myCurrentLetterRange = GetNextLetterRange(IIf(ipDocument Is Nothing, ActiveDocument, ipDocument))
Loop
End Sub
Private Function GetNextLetterRange(ByRef ipDocument As Word.Document) As Word.Range
' The use of Static means that the vairable will be remembered between calls
' so we don't need a module or global level variable to remeber it for us.
'
' On the first method call the variable myLetterRange will be 'nothing' as it won't
' yet have been initialised.
' This code uses the assumption that the individual letters are separated by
' a manual page break. In a word document this is the equivalent of a character
' with the code of 12
Static myLetterRange As Word.Range
' There are two special cases we need to deal with
'1. the first use of this function
'2. the end of the document
' On first use myLetterRange will not have been initialised so will be nothing
If myLetterRange Is Nothing Then
Set myLetterRange = ipDocument.StoryRanges(wdMainTextStory)
' Lets start at the beginning
myLetterRange.Collapse direction:=wdCollapseStart
' If we have reached the end of the document then we return nothing
ElseIf myLetterRange.End = ipDocument.Range.End Then
Set myLetterRange = Nothing
' In this case we can go home early
Exit Function
' If it not the start or the end of the document then we need to skip over the
' manual page break to get to the first character of the next letter
Else
myLetterRange.Collapse direction:=wdCollapseEnd
myLetterRange.Move unit:=wdCharacter, Count:=1
End If
' Now we can look for the manual page break that marks the end of the letter
' Moveenduntil will return the number of characters moved but will
' return 0 if we don't find any characters in cset
' This will happen at the last page of the document so to be able to return
' the range of the last page of the document we need to set the end of
' myLetterRange manually
If myLetterRange.MoveEndUntil(cset:=Chr$(12), Count:=wdForward) = 0 Then
myLetterRange.End = ipDocument.StoryRanges(wdMainTextStory).End
End If
'We don't want the user to corrupt our range so we return a copy
Set GetNextLetterRange = myLetterRange.Duplicate
End Function
Private Function GetClientname(ByRef ipLetterRange As Word.Range) As String
' The problem we have here is that the only clue we have as to the address block is
' that the 'Client' name lives in characters 10 to 30 of the letter range
' For the purposes of this code we'll assume that characters
' 10 to 30 live in paragraph 1 of the document.
' if this isn't the case you'll need to change the pragraph number and possible
' the numbers describing the start and end of the range
Dim myNameRange As Word.Range
Set myNameRange = ipLetterRange.Paragraphs(1).Range.Characters.First 'alternative is .characters(1)
myNameRange.MoveStart unit:=wdCharacter, Count:=10
' In this case the move also moves the end of the range
myNameRange.MoveEnd unit:=wdCharacter, Count:=20
GetClientname = myNameRange.Text
End Function
Private Function TrySaveIndividualLetter(ByRef ipLetterRange As Word.Range, ByVal ipClientName As String) As Boolean
Dim myLetter As Word.Document
Dim myLetterName As String
Set myLetter = Application.Documents.Add(Visible:=False)
' We give a name to the new letter as being the parentlettername_clientname
' delete the bits you don't want
' Use the docX extension that matches your multiple letter document
' in the line below
myLetterName = _
ipLetterRange.Document.Path _
& "\" _
& Replace(ipLetterRange.Document.Name, ".docm", vbNullString) _
& "_" _
& ipClientName _
& ".docx"
' Copy the formatted text in the found letter range into the new document
' copy/paste mioght be a better apprach if the range contains graphics.
myLetter.Range.FormattedText = ipLetterRange.FormattedText
myLetter.SaveAs2 myLetterName
TrySaveIndividualLetter = myLetter.Saved
myLetter.Close
End Function
