Einzelne Word-Seiten mittels VBA in ein neues Dokument kopieren

Sub Seiten_kopieren()
  Dim iMaxPage%, sAntwort$, i%, ii%, sTmp$
  Dim arr, arrSeiteVonBis
  Dim nDoc, oRange As Range, oQuelle, oZiel
  On Error GoTo Errors_
  Set oQuelle = ActiveDocument
  iMaxPage = oQuelle.ComputeStatistics(wdStatisticPages)
  sAntwort = InputBox(InputBoxTxt(iMaxPage), "Seite kopieren", "1-" & iMaxPage)
  If sAntwort = "" Then GoTo Exit_
  Application.ScreenUpdating = False
  sTmp = ""
  For i = 1 To Len(sAntwort) 'Ueberpruefung ob nur "0-9" "," "-" in der Eingabe
    Select Case Asc(Mid(sAntwort, i, 1))
      Case 48 To 57, 44, 45
      Case Else
        sTmp = sTmp & Mid(sAntwort, i, 1) & " "
      Exit Sub
    End Select
  Next
  If sTmp <> "" Then MsgBox "Ungültige Eingabe " & Chr(39) & Mid(sAntwort, i, 1) & Chr(39)
  arr = Split(sAntwort, ",")
  Set oZiel = Documents.Add
  For i = 0 To UBound(arr)
    If InStr(arr(i), "-") = 0 Then arr(i) = arr(i) & "-" & arr(i)
    arrSeiteVonBis = Split(arr(i), "-")
    For ii = arrSeiteVonBis(0) To arrSeiteVonBis(1)
      sTmp = CStr(ii)
      oQuelle.Activate
      Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=sTmp
      Set oRange = Documents(oQuelle).Bookmarks("\Page").Range
      oRange.Select
      'If Right(oRange.Text, 1) = Chr(12) Then 'Seitenumbruch ausschliessen
      '  oRange.SetRange Start:=oRange.Start, End:=oRange.End - 1
      'End If
      Selection.Copy
      oZiel.Activate
      Selection.Paste
    Next
  Next
  oQuelle.Activate
  Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=1
  Set oZiel = Nothing
  Set oQuelle = Nothing
Errors_:
  Err.Clear
Exit_:
  Application.ScreenUpdating = True
End Sub

Function InputBoxTxt(ByVal sRange$) As String
  Dim sTmp$
  sTmp = "Welche Seite(n) soll(en) kopiert werden?" & vbCrLf
  sTmp = sTmp & "1 - " & sRange & vbCrLf & vbCrLf
  sTmp = sTmp & "Sie können nur eine aber auch mehrere Seiten angeben" & vbCrLf
  sTmp = sTmp & "Trennzeichen sind " & Chr(39) & "," & Chr(39) & " und " & Chr(39) & " - " & Chr(39) & vbCrLf & vbCrLf
  sTmp = sTmp & "Gültige Engabebeispiele:" & vbCrLf
  sTmp = sTmp & "3" & vbTab & vbTab & "Seite 3 wird kopiert" & vbCrLf
  sTmp = sTmp & "3,7,12" & vbTab & vbTab & "Seiten 3 7 12 werden kopiert" & vbCrLf
  sTmp = sTmp & "3,7-12,15" & vbTab & "Seiten 3 7 8 9 10 11 12 15 werden kopiert" & vbCrLf
  InputBoxTxt = sTmp
End Function

Wir nutzen Cookies auf unserer Website. Einige von ihnen sind essenziell für den Betrieb der Seite, während andere uns helfen, diese Website und die Nutzererfahrung zu verbessern (Tracking Cookies). Sie können selbst entscheiden, ob Sie die Cookies zulassen möchten. Bitte beachten Sie, dass bei einer Ablehnung womöglich nicht mehr alle Funktionalitäten der Seite zur Verfügung stehen.