macro button to split 1 doc into two docs, then delete itself

[Rob Benz]

I'm looking for suggestions on how to construct a macro button in a document
that, when clicked,

a) splits the document into two documents, at the location where the macro
button is placed;
b) deletes the macro button itself, so it no longer appears in either
document;
c) saves the two documents in the same location where the original document
resided. (doc A keeps same name and overwrites its parent; doc B is just a
new .doc with some kind of minor name modification like "Copy of [docA.doc]".)

 

[Pesach Shelnitz]

Hi Rob,

Try this. I assume that you know how to create the macro button.

Sub SplitDoc()
Dim myRange As Range
Dim doc As Document
Dim name As String
Dim i As Integer
Dim pSize As WdPaperSize
Dim pWidth As Single
Dim pHeight As Single
Dim hdDist As Single
Dim ftDist As Single
Dim lMargin As Single
Dim rMargin As Single
Dim tMargin As Single
Dim bMargin As Single

Selection.Fields(1).Select
name = ActiveDocument.FullName
i = InStr(1, name, ".doc")
If i = 0 Then
MsgBox "The file name must have the .doc or .docx extension."
Exit Sub
End If
name = Left(name, i - 1)
With ActiveDocument.PageSetup
pSize = .PaperSize
pHeight = .PageHeight
pWidth = .PageWidth
hdDist = .HeaderDistance
ftDist = .FooterDistance
lMargin = .LeftMargin
rMargin = .RightMargin
tMargin = .TopMargin
bMargin = .BottomMargin
End With
Set myRange = ActiveDocument.Range(Start:=Selection.End +1, _
End:=ActiveDocument.Bookmarks("\EndOfDoc").Range.Start)
Set doc = Documents.Add(ActiveDocument.AttachedTemplate.FullName)
With doc.PageSetup
.PaperSize = pSize
.PageHeight = pHeight
.PageWidth = pWidth
.HeaderDistance = hdDist
.FooterDistance = hdDist
.LeftMargin = lMargin
.RightMargin = rMargin
.TopMargin = tMargin
.BottomMargin = bMargin
End With
doc.Range.FormattedText = myRange.FormattedText
doc.SaveAs fileName:=name & "_Part2", _
FileFormat:=ActiveDocument.SaveFormat
doc.Close
myRange.Delete
Selection.Fields(1).Delete
ActiveDocument.Save
Set doc = Nothing
Set myRange = Nothing
End Sub

 

[fumei]

Here is another version.

Sub SplitMeUpScotty()

Dim SecondPart As Range
Dim ThisDoc As Document
Dim NewDoc As Document
Dim ThisDocPath As String
Dim ThisDocName As String
' get doc Path and Name
ThisDocPath = ActiveDocument.Path & "\"
ThisDocName = ActiveDocument.Name

Set ThisDoc = ActiveDocument
' collapse Selection so it is just BEFORE
' the MACROBUTTON
Selection.Collapse 1

Set SecondPart = ActiveDocument.Range( _
Start:=Selection.Start, _
End:=ActiveDocument.Range.End)
Set NewDoc = Documents.Add
With NewDoc
.Range = SecondPart
' delete what was the macrobutton
.Range.Words(1).Delete
' save in same folder with new name
.SaveAs FileName:=ThisDocPath & "Copy of " & _
ThisDocName
.Close
End With
Set NewDoc = Nothing
' delete the second part from original
SecondPart.Delete
' and save
ThisDoc.Save
Set ThisDoc = Nothing
End Sub