Splitting Word Document based on line content

macropod · #16 10-07-2015, 03:45 PM

OK, try the following macro. You run it from the document you want to split.

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTmp As String, StrNames As String
Dim DocSrc As Document, DocTgt As Document
StrNames = "|"
Set DocSrc = ActiveDocument
With DocSrc
  With .Range
    .InsertBefore Chr(13) & Chr(13)
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "^13^13[!^13]@^13"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      StrTmp = Trim(Split(.Text, "/")(0))
      StrTmp = Split(StrTmp, " ")(UBound(Split(StrTmp, " ")))
      If InStr(StrNames, "|" & StrTmp & "|") = 0 Then StrNames = StrNames & StrTmp & "|"
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  For i = 1 To UBound(Split(StrNames, "|")) - 1
    StrTmp = Split(StrNames, "|")(i)
    Set DocTgt = Documents.Add
    With .Range
      With .Find
        .Text = "^13^13[!^13]@" & StrTmp & "*^13"
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        .MoveEndUntil Chr(13) & Chr(13), wdForward
        DocTgt.Range.Characters.Last.FormattedText = .FormattedText
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    With DocTgt
      With .Range
        .Characters.First.Delete
        .Characters.First.Delete
      End With
      .SaveAs2 FileName:=DocSrc.Path & "\" & StrTmp & ".docx", _
        Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
      .Close
    End With
  Next
  With .Range
    .Characters.First.Delete
    .Characters.First.Delete
  End With
End With
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

TwiceOver · #17 10-08-2015, 07:19 AM

Wow, didn't expect you to write the whole thing for me! Thanks for all the work!

So I copied my 3 example topics into a new word document then created the macro copied from your post.

It adds two LineFeeds to the beginning and then deletes them. It never executes any of the Do While .Find.Found loops

It also skips over the For / Next loop.

I'm dissecting the macro now to try and figure out what all it is doing.

macropod · #18 10-08-2015, 03:38 PM

The macro works when the content from your posts is simply copied and pasted into a new document. That is doesn't work with your actual document suggests it doesn't quite match your description or the examples you gave. Can you attach an actual document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

TwiceOver · #19 10-08-2015, 03:50 PM

Quote:

Originally Posted by macropod

The macro works when the content from your posts is simply copied and pasted into a new document. That is doesn't work with your actual document suggests it doesn't quite match your description or the examples you gave. Can you attach an actual document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

I'll have to try it again, but that is exactly what I did. Copied the block of text from my post, into a new document and ran the macro. I'll work on it again tomorrow when I get back in.

Tried it again just now, nothing.

macropod · #20 10-09-2015, 07:37 PM

If you had saved the document before running the macro, the output files would be found in the same folder as your saved document. If the document wasn't saved, you'd either get an error message or the output files might be found in a Temp folder (e.g. C:\Users\%UserName%\AppData\Local\Temp)

TwiceOver · #21 10-10-2015, 04:27 AM

Hrm... I don't know what I'm doing wrong. The macro isn't even getting to the part to save the files. It is not executing the Do While or the For i loop. Stepping through the macro it passes right over those, so it doesn't appear to be finding the string that it is set to look for.

I'm running this against the text copied out of Post #15 in this thread.

macropod · #22 10-10-2015, 05:15 AM

If you just copy & paste from the website, rather than copying & pasting as unformatted text, everything ends up in one big paragraph with line breaks instead of paragraph breaks.

TwiceOver · #23 10-12-2015, 12:51 PM

Quote:

Originally Posted by macropod

If you just copy & paste from the website, rather than copying & pasting as unformatted text, everything ends up in one big paragraph with line breaks instead of paragraph breaks.

Thanks! That definitely tried to work. I removed the line feed characters between the separate paragraphs and the helped. Bob.docx ended up with the first two items which are both bob and julie items, and the third item didn't end up anywhere.

macropod · #24 10-12-2015, 02:01 PM

There should have been two instances of 'Bob' in the Bob file, but I've also realised the code wasn't picking up the full range for each. Try this code revision:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTmp As String, StrNames As String
Dim DocSrc As Document, DocTgt As Document
StrNames = "|"
Set DocSrc = ActiveDocument
With DocSrc
  With .Range
    .InsertBefore Chr(13) & Chr(13)
    .InsertAfter Chr(13)
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "^13^13[!^13]@^13"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      StrTmp = Trim(Split(.Text, "/")(0))
      StrTmp = Split(StrTmp, " ")(UBound(Split(StrTmp, " ")))
      If InStr(StrNames, "|" & StrTmp & "|") = 0 Then StrNames = StrNames & StrTmp & "|"
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  For i = 1 To UBound(Split(StrNames, "|")) - 1
    StrTmp = Split(StrNames, "|")(i)
    Set DocTgt = Documents.Add
    With .Range
      With .Find
        .Text = "^13^13[!^13]@" & StrTmp & "*^13^13"
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        .Start = .Start + 1
        .End = .End - 1
        DocTgt.Range.Characters.Last.FormattedText = .FormattedText
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    With DocTgt
      .Range.Characters.First.Delete
      .Range.Characters.Last.Delete
      .SaveAs2 FileName:=DocSrc.Path & "\" & StrTmp & ".docx", _
        Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
      .Close
    End With
  Next
  With .Range
    .Characters.First.Delete
    .Characters.First.Delete
    .Characters.Last.Delete
  End With
End With
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
split word document based on bookmarks with each new document title of the bookmark	megatronixs	Word VBA	9	09-05-2020 02:29 PM
More than one content controls in a word document	lucky16	Word VBA	6	07-10-2014 08:34 AM
Document splitting	MsLavigne	Word	2	05-09-2012 05:52 AM
WORD 2003 Need help splitting a HUGE Document	dlawson	Word	4	04-14-2009 12:22 PM
How to add Table of Content in word document by C# ! ! !	arun singh	Word	0	11-12-2008 11:21 PM