vba - VBA Word 拆分并使用指定名称保存

Question

我希望这里有人可以帮助我。我有一份包含 365 封求职信的文档，我需要将其拆分为单独的文档，并将它们与地址块中的名称一起保存。有人可以帮我修改这段代码吗？以为我弄明白了，但我仍然遇到错误。

这是我尝试过但不起作用的代码。

Sub SplitIntoPages()
    Dim docMultiple As Document
    Dim docSingle As Document
    Dim rngPage As Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String

    Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
    flicker a bit.
    Set docMultiple = ActiveDocument 'Work on the active document _
    '(the one currently containing the Selection)
    Set rngPage = docMultiple.Range 'instantiate the range object
    iCurrentPage = 1
    'get the document's page count
    iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)

    Do Until iCurrentPage > iPageCount
        If iCurrentPage = iPageCount Then
            rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
        Else
'Find the beginning of the next page
'Must use the Selection object. The Range.Goto method will not work on a page
            Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
        'Set the end of the range to the point between the pages
             rngPage.End = Selection.Start
        End If

    rngPage.Copy 'copy the page into the Windows clipboard
    Set docSingle = Documents.Add 'create a new document
    docSingle.Range.Paste 'paste the clipboard contents to the new document
    'remove any manual page break to prevent a second blank
    docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
    'build a new sequentially-numbered file name based on the original multi-paged file name and path

    Set objFileName = objNewDoc.Range(Start:=10, End:=30 & ".doc") 'docSingle.SaveAs objNewDoc.Range(Start:=10, End:=30 & ".doc") 'save the new single-paged document

    iCurrentPage = iCurrentPage + 1 'move to the next page
    docSingle.Close 'close the new document
    rngPage.Collapse wdCollapseEnd 'go to the next page
    Loop 'go to the top of the do loop

    Application.ScreenUpdating = True 'restore the screen updating

    'Destroy the objects.
    Set docMultiple = Nothing
    Set docSingle = Nothing
    Set rngPage = Nothing
End Sub

这是我使用的原始代码，但将单个文档命名为原始文档的名称，并在末尾添加页码。

我希望得到一个代码，它将文件命名为地址块中的名称。任何帮助都可以提前谢谢你。

标签： vbasplitms-wordsave

Answer 1

@JenniferVazquez 你的代码有很多问题。

1. 您有许多未声明的变量。这可能是因为您没有将“选项显式”作为模块的第一行。始终始终将选项显式放在您编写的任何模块或类的第一行。

然后在尝试运行代码之前始终执行 Debug.Compile。

除了 'Option Explicit' 和 Debug.COmpile，如果您的公司允许，请安装神奇的 RubberDuck 插件并密切注意此插件可以提供的代码检查。

2. 您实际上还没有给新文件命名。事实上，您的代码不太可能像上面给出的那样运行。

3. 您真的应该提供一个示例文档，我们可以根据它检查您的代码，看看我们是否得到与您相同的结果，并在我们编写新代码或更新您的代码时为我们提供帮助。

我已经编写了一些代码，我认为这些代码可以完成您的原始代码正在尝试做的事情。在我的代码中，我将活动拆分为不同的功能。如果我更加努力，我可以将我的代码拆分成更小的函数，但我想你会看到总体思路。

感谢您在代码中添加大量注释，它确实使您更容易弄清楚您正在尝试做什么。

我希望下面的代码可以帮助你。

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

结束功能