Sub Copy_And_PastRandomly()
Dim p As Paragraph, capCount As Long, arrpos As Long, ft As Long, i As Long
Dim arr(), Quelle As Document, Ziel As Document
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