Hallo JD,

zunächst mal solltest du die 10000 durch den höchsten Datensatz (ActiveDocument.MailMerge.DataSource.RecordCount) ersetzen. Gibt es z.B. nur 100 Datensätze, wird sonst überflüssigerweise der letzte Datensatz immer wieder neu angelegt bis die 10000 erreicht ist.

Auf den Befehl ChangeFileOpenDirectory kannst du verzichten. Das Öffnen, Schließen und Wechseln von Ordnern in Windows kostet viel Zeit. Gib stattdessen einen absoluten Pfad unter FileName an. Also: FileName = Pfad & i & "\" & i & ".txt". Die Variable Pfad muss natürlich mit "\" abschließen.

Nach jedem Speichern wieder das ActiveDocument auszulesen um darauf referenzieren zu können kostet ebenfalls Zeit. Schreibe dieses vor Beginn der Schleife in eine Variable oder referenziere mit einem With-Block darauf.

Auch das ständige Durchhangeln über die Unterobjekte .MailMerge.Datassource.ActiveRecord kann u.U. Zeit kosten. Auch wenn es nur Millisekunden sind, kommt bei großen Schleifen ganz schön was zusammen. Auch hier empfiehlt sich deshalb eine Variable oder ein With-Block.

Versuch also mal diesen Code:

Sub Speichern()

Dim i As Integer
Dim Pfad As String
Dim Doc As Document
Dim ds As MailMergeDataSource
Dim cnt As Long
Pfad = "xxx"

Set Doc = ActiveDocument
Doc.MailMerge.ViewMailMergeFieldCodes = False
Set ds = Doc.MailMerge.DataSource
cnt = ds.RecordCount
ds.ActiveRecord = wdFirstRecord

For i = 1 To cnt
  MkDir Pfad & i
  Doc.SaveAs2 FileName:=Pfad & i & "\" & i & ".txt", FileFormat:=wdFormatText
  ds.ActiveRecord = wdNextRecord
Next i

MsgBox "Ende"

End Sub

Da du aber jedesmal auf das Dateisystem zugreifst um einen neuen Ordner und darin die Datei zu erstellen, kommst du um eine gewisse Wartezeit bis zum Ende des Makros leider nicht umhin. Du kannst höchstens den Windows-Explorer zuvor schließen, damit dieser nicht auch noch nach jedem Ordner aktualisiert wird.

Gruß Mr. K.