Blue Flower

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