Split and name Word file using VBA script

Question

I have a file that I would like to split into multiple files using a specific delimiter. I would like to have the resulting files named using the text that immediately follows the delimiter. I have found several examples of people trying to do this, but none of the script examples work for me.

Here is a link with a small file showing what I am trying to do: https://digitalmeasures-my.sharepoint.com/personal/dsarnowski_digitalmeasures_com/_layouts/15/guestaccess.aspx?docid=1646acdaa4b2c45859090b24f90f17d4e&authkey=AZ4tRnX30dQRw9-8enYBCTk

Here is the content of the file:

///DavidSarnowski

David Sarnowski

Report Content

Report Footer

///LeahWilliams

Leah Williams

Report Content

Report Footer

///BrettSmith

BrettSmith

Report Content

Report Footer

My desired output would look like this:

Three files:

• DavidSarnowski.doc
• LeahWilliams.doc
• BrettSmith.doc

The content of the file for DavidSarnowski.doc would look like this:

David Sarnowski

Report Content

Report Footer

I am a VBA newbie and not sure if this can work and/or how you would do it. Any help would be greatly appreciated.

***Post moved by the moderator to the appropriate forum category.***

Answer 1

Try downloading from: OneDrive

Note: If you copied & pasted the code directly from my post above into the VBE, it's possible you ended up with a bunch of invalid non-breaking spaces in the code. If you paste the code into an empty Word document and do a Find/Replace, with:

Find = ^s

Replace = ^32

That will turn them back into normal spaces. You should then be able to paste the code into the VBE and have it work correctly.

Answer 2

Paul, can you link to or attach a copy of a Word document with the macro in it so I could run it on my end?

Answer 3

The code works fine for me with the sample data in your linked document. Did any new documents get created?

Answer 4

@Macropod, thank for giving this a shot. When I ran the macro I received this error:

"Run-time error '438':

Object doesn't support this property or method"

When I debugged it, it highlighted this line:

.SaveAs2 fileName:=FlPth & StrNm & Ext, Fileformat:=Fmt, AddToRecentFiles:=False

Any thoughts?

Answer 5

Try:

Sub SplitDoc()

Application.ScreenUpdating = False

Dim Rng As Range, DocSrc As Document, DocTgt As Document, StrNm As String

Dim Ext As String, FlPth As String, Tmplt As String, Fmt As Long

Set DocSrc = ActiveDocument

With DocSrc

  Ext = "." & Split(.Name, ".")(UBound(Split(.Name, ".")))

  FlPth = .Path & ""

  Tmplt = .AttachedTemplate.FullName

  Fmt = .SaveFormat

  With .Range

    .InsertAfter vbCr & "///"

    With .Find

      .ClearFormatting

      .Replacement.ClearFormatting

      .Text = "[//]{3}*^13"

      .Replacement.Text = ""

      .Forward = True

      .Wrap = wdFindStop

      .Format = False

      .MatchWildcards = True

      .Execute

    End With

    Do While .Find.Found

      If .End = DocSrc.Range.End Then GoTo Finished

      Set Rng = .Duplicate

      With Rng

        .MoveEndUntil "///", wdForward

        StrNm = Split(Split(.Paragraphs.First.Range.Text, vbCr)(0), "///")(1)

        .Start = .Paragraphs.First.Range.End

        Set DocTgt = Documents.Add(Tmplt)

        With DocTgt

          .Range.FormattedText = Rng.FormattedText

          .SaveAs2 FileName:=FlPth & StrNm & Ext, Fileformat:=Fmt, AddToRecentFiles:=False

          .Close False

        End With

      End With

      .Collapse wdCollapseEnd

      .Find.Execute

    Loop

  End With

End With

Finished:

Undo: Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing

Application.ScreenUpdating = True

End Sub