Save split docs with same name as original

[Rudi]

Hi,

I have this code (below), that splits a large doc at specific text reoccurences. I'd like for the split off sub docs to be saved with the same name as the original (incl. the suffix number).
For example: Main doc is called Master. The sub docs must be saved as: Master 001, Master 002, Master 003, etc...

TX

Code: Select all

Sub RunSplitDoc()
    Dim docS As Document
    Dim docT As Document
    Dim myFind As String
    Dim i As Long
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim wdDoc As Word.Document
    Dim FullFileName As String
    
    Selection.HomeKey Unit:=wdStory
    myFind = InputBox("Supply the text string to find that indicates where the document must be split.", _
        "Split Position")
    If myFind = "" Then
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set docS = ActiveDocument
    i = -1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = myFind
        .Wrap = wdFindStop
        Do While .Execute
            i = i + 1
            lngStart = lngEnd
            lngEnd = Selection.Start
            If i > 0 Then
                Set docT = Documents.Add
                docS.Range(Start:=lngStart, End:=lngEnd).Copy
                docT.Content.Paste
                docT.SaveAs FileName:=docS.Path & "\" & "SubDoc " & Format(i, "000")
                docT.Close
            End If
        Loop
    End With
    i = i + 1
    lngStart = lngEnd
    lngEnd = docS.Content.End
    Set docT = Documents.Add
    docS.Range(Start:=lngStart, End:=lngEnd).Copy
    docT.Content.Paste
    docT.SaveAs FileName:=docS.Path & "\" & "SubDoc " & Format(i, "000")
    docT.Close
    Selection.HomeKey Unit:=wdStory
    Application.ScreenUpdating = True
    MsgBox "Data splitting is complete. The split documents are in the same place as this current document.", vbInformation
End Sub

[HansV]

Try this version. I added a few comments to indicate where I changed the code.

Code: Select all

Sub RunSplitDoc()
    Dim docS As Document
    Dim docT As Document
    Dim myFind As String
    Dim i As Long
    Dim lngStart As Long
    Dim lngEnd As Long
    Dim wdDoc As Word.Document
    Dim FileName As String
    Dim PointPos As Long

    Selection.HomeKey Unit:=wdStory
    myFind = InputBox("Supply the text string to find that indicates " & _
        "where the document must be split.", "Split Position")
    If myFind = "" Then
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set docS = ActiveDocument
    ' Get name of source document
    FileName = docS.Name
    ' Get position of last . in file name
    PointPos = InStrRev(FileName, ".")
    ' Extract part before the point
    FileName = Left(FileName, PointPos - 1)
    i = -1
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = myFind
        .Wrap = wdFindStop
        Do While .Execute
            i = i + 1
            lngStart = lngEnd
            lngEnd = Selection.Start
            If i > 0 Then
                Set docT = Documents.Add
                docS.Range(Start:=lngStart, End:=lngEnd).Copy
                docT.Content.Paste
                ' Use original file name + suffix
                docT.SaveAs FileName:=docS.Path & "\" & FileName & Format(i, " 000")
                docT.Close
            End If
        Loop
    End With
    i = i + 1
    lngStart = lngEnd
    lngEnd = docS.Content.End
    Set docT = Documents.Add
    docS.Range(Start:=lngStart, End:=lngEnd).Copy
    docT.Content.Paste
    ' Use original file name + suffix
    docT.SaveAs FileName:=docS.Path & "\" & FileName & Format(i, " 000")
    docT.Close
    Selection.HomeKey Unit:=wdStory
    Application.ScreenUpdating = True
    MsgBox "Data splitting is complete. The split documents are in the same " & _
        "place as this current document.", vbInformation
End Sub

[Rudi]

Similarly,

I have this code...doing more or less the same thing as above, but I need the sub files saved into the same location as the master doc.
The code I want to put in the Normal template. When I do this, the sub docs are not save where the original is, but in the "C:\Users\<username>\AppData\Roaming\Microsoft\Templates" folder.

Could this be changed?
TX.

Code: Select all

Dim myFind As String, myQ As Byte

Sub RunSplitNotes()
    myQ = 0
    GetSplitPosition
    If myQ = 1 Then Exit Sub
    'delimiter & filename
    SplitNotes "/@/", "Notes "
    CleanOrig
End Sub

Private Sub GetSplitPosition()
'
    myFind = InputBox("Supply the text string to find that indicates where the document must be split.", "Split Position")
    If myFind = "" Then
        myQ = 1
        Exit Sub
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = myFind
        .Replacement.Text = "/@/ ^p " & myFind
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.HomeKey Unit:=wdStory
End Sub

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document
    Dim arrNotes
    Dim i As Long
    Dim X As Long
    Dim Response As Integer

    Set doc = ActiveDocument
    arrNotes = Split(ActiveDocument.Range, delim)
    
    Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
    If Response = 7 Then Exit Sub
    For i = LBound(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(i)) <> "" Then
            X = X + 1
            Set doc = Documents.Add
            doc.Range = arrNotes(i)
            doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
            doc.Close True
        End If
    Next i
End Sub

Private Sub CleanOrig()
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "/@/ ^p"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.HomeKey Unit:=wdStory
End Sub

[Rudi]

Try this version. I added a few comments to indicate where I changed the code.

Excellent. Works perfect!
TX for the comments!

Cheers

[HansV]

I have this code...doing more or less the same thing as above, but I need the sub files saved into the same location as the master doc.

Change the line

Code: Select all

            doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")

to

Code: Select all

            doc.SaveAs ActiveDocument.Path & "\" & strFilename & Format(X, "000")

[Rudi]

I actually did that, but then it saves to the C:\ drive as the activedoc at the point in the code is a blank new unsaved doc.

Through some more trial (and error), I got there with this...
I have to capture the activedoc in a variable before the new doc is created.

Code: Select all

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document, docOrig As Document
    Dim arrNotes
    Dim i As Long
    Dim X As Long
    Dim Response As Integer

    Set docOrig = ActiveDocument
    arrNotes = Split(ActiveDocument.Range, delim)
    
    Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
    If Response = 7 Then Exit Sub
    For i = LBound(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(i)) <> "" Then
            X = X + 1
            Set doc = Documents.Add
            doc.Range = arrNotes(i)
            doc.SaveAs docOrig.Path & "\" & strFilename & Format(X, "000")
            doc.Close True
        End If
    Next i
End Sub

TX for you guidance. Appreciated!