Salvar Mala Direta Em Arquivos Separados

[Axtype]

Boa tarde galera!

É o seguinte, estou com um problemão, mas não estou conseguindo resolver, pois não tenho conhecimento avançado em VBA, peço por gentileza uma ajuda de vocês.

Tenho um modelo de carta no Word que captura alguns campos de uma planilha que tenho no excel, ele captura o campo E-mail e Senha.

Até consigo gerar a mala direta, mas quando tenho muitos registros, ele gera em um arquivo só todos os registros e preciso que gere em arquivos .doc separados.

Alguém saberia me dizer como fazer isso, mas peço que detalhem o máximo para mim pois sou totalmente novato nesse assunto.

Ah detalhe em minhas pesquisas até encontrei algo parecido, mas não consegui fazer funcionar, pois não sei se estou fazendo a coisa certa, o codigo que encontrei esta abaixo em vermelho.

Obrigado Galera!

CODE

Sub SalvaComo Arqs

' Converte todas as seções para subdocumentos

TudoParaSubDocs ActiveDocument

' Salva cada subdocumento como um arquivo separado

SalvaTodosSubDocs ActiveDocument

End Sub

CODE

Sub TudoParaSubDocs(ByRef doc As Word.Document)

Dim ctaSec As Long

Dim 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

CODE

Sub SalvaTodosSubDocs(ByRef doc As Word.Document)

Dim subdoc As Word.Subdocument

Dim NovoDoc As Word.Document

Dim ContaDocs As Long

ContaDocs = 1

' Deve estar em Exibir Mestre para trabalhar com

' Subdocs como arquivos separados

doc.ActiveWindow.View = wdMasterView

For 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 NovoDoc

With NovoDoc

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

.Close

End With

ContaDocs = ContaDocs + 1

Next subdoc

End Sub

CODE

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

[Axtype]

Alguém consegue me dar um auxilio?