Hallo,

Probiers mal mit diesem Code. Der sollte das gewünschte machen. Er speichert die Positionen der Absätze mit einem zufälligen Indexin ein Array und liest dann das Array von oben nach unten aus. Dann kopiert er den an der ausgelesenen Position gefundenen Absatz und fügt ihn hinten in ein neues Dokument ein.

Sub Copy_And_PastRandomly()

Dim p As Paragraph, capCount As Long, arrpos As Long, ft As Long, i As Long 'ft=Anzahl Paragraphst im Folgetext bis zur nächsten Überschrift.
Dim arr(), Quelle As Document, Ziel As Document

'On Error GoTo Fehler

For Each p In ActiveDocument.Paragraphs
  If p.Style = "Überschrift 1" Then
    capCount = capCount + 1
  End If
Next p

ReDim arr(1 To capCount, 1 To 2)

For Each p In ActiveDocument.Paragraphs
  i = i + 1
  If p.Style = "Überschrift 1" Then
    Do
      arrpos = Int(Rnd * capCount) + 1
    Loop Until arr(arrpos, 1) = 0
    arr(arrpos, 1) = i
    arr(arrpos, 2) = 0
  Else
    arr(arrpos, 2) = arr(arrpos, 2) + 1
  End If
Next p

Set Quelle = ThisDocument
Set Ziel = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)

Application.ScreenUpdating = False
For i = 1 To capCount
  Quelle.Range(Quelle.Paragraphs(arr(i, 1)).Range.Start, Quelle.Paragraphs(arr(i, 2) + arr(i, 1)).Range.End).Copy
  Ziel.Range(Ziel.Range.End - 1, Ziel.Range.End - 1).PasteAndFormat wdPasteDefault
Next i
 
Application.ScreenUpdating = True
Debug.Print x
MsgBox "Fertig!"
Exit Sub

Fehler:
If Err = 4605 Then
  x = x + 1
  Err.Clear
  Resume
Else
  MsgBox "Fehler: " & Err & vbNewLine & Err.Description
End If

End Sub

Allerdings erhalte ich hier bei Paste einen Laufzeitfehler den ich nicht so richtig greifen kann. "Fehler 4605 Dieser Befehl ist nicht verfügbar." Solltest du den auch erhalten entferne das Apostroph vor On Error goto Fehler führe nochmal aus und warte ein bisschen. Irgendwann macht er dann trotz Fehler das was er soll. Kann aber eine Minute dauern.

Gruß Mr. K.