Sub SalvaComo Arqs' Converte todas as seções para subdocumentos

TudoParaSubDocs ActiveDocument

' Salva cada subdocumento como um arquivo separado

SalvaTodosSubDocs ActiveDocument

End Sub

  

Sub TudoParaSubDocs(ByRef doc As Word.Document)Dim ctaSec As LongDim NrSecs As Long

NrSecs = doc.Sections.Count

' Inicial pelo final porque a criação de ' Subdocs iinsere seções adicionais

For ctaSec = NrSecs - 1 To 1 Step -1

doc.Subdocuments.AddFromRange doc.Sections(ctaSec).Range

Next ctaSec

End Sub

 

Sub SalvaTodosSubDocs(ByRef doc As Word.Document)Dim subdoc As Word.SubdocumentDim NovoDoc As Word.DocumentDim ContaDocs As Long

ContaDocs = 1

' Deve estar em Exibir Mestre para trabalhar com' Subdocs como arquivos separados

doc.ActiveWindow.View = wdMasterViewFor Each subdoc In doc.Subdocuments

Set NovoDoc = subdoc.Open

' Remove as quebras de seção Próxima Página' Geradas pela fusão dos arquivos

RemoveQuebrasSec NovoDocWith NovoDoc

.SaveAs FileName:="Arquivo" & CStr(ContaDocs).Close

End WithContaDocs = ContaDocs + 1

Next subdoc

End Sub

  Sub RemoveQuebrasSec(doc As Word.Document)

With doc.Range.Find

.ClearFormatting.Text = "^b"With .Replacement

.ClearFormatting.Text = ""

End With.Execute Replace:=wdReplaceAll

End With

End Sub