Форум по VBA и MS Office

Sub макрос()
   
    Dim doc_act As Document, doc_new As Document
    Dim PagesNumbers, PageNumber1 As Long, PageNumber2 As Long
    Dim start_ As Long, end_ As Long
    Dim spl, i As Long
   
   
    '1. Юзер указывает номера страниц с помощью инпутбокса.
    PagesNumbers = InputBox("Укажите номера страниц. Пример: 1,3,5-7.")
    ' Если юзер щёлкнул "Cancel".
    If PagesNumbers = "" Then
        Exit Sub
    End If
    ' Разбивка номеров страниц по запятым, чтобы получился массив.
    PagesNumbers = Split(PagesNumbers, ",")
   
    '2. Отключение монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '3. Присваиваем активному файлу (это файл, который отображается на мониторе) имя "doc_act".
        ' После создания нового файла, активным файлом станет новый файл, и уже нельля
        ' будет обратиться к исходному активному файлу, используя объект "ActiveDocument".
    Set doc_act = ActiveDocument
   
    '4. Проверка, что юзер указал существующие номера страниц.
    If VerifyPagesNumbers(doc_act, PagesNumbers) = False Then
        Exit Sub
    End If
   
    '5. Создание нового пустого файла и присваивание ему имени "doc_new".
    Set doc_new = Documents.Add
   
    '6. Копирование указанных страниц в новый файл.
        ' При использовании функции "Split" создаётся массив, в котором у первого элемента
        ' порядковый номер 0.
    For i = 0 To UBound(PagesNumbers)
       
        '1) Разбивка данных по дефису.
        spl = Split(PagesNumbers(i), "-")
       
        '2) Копирование номеров страниц из массива "spl" в две переменные.
        ' Если один элемент в массиве "spl", значит дефиса нет и нужно работать с одной страницей.
        If UBound(spl) = 0 Then
            ' Запись в переменные номеров страниц, с которыми надо работать.
            PageNumber1 = spl(0)
            PageNumber2 = spl(0)
        ' Если есть дефис, значит нужно работать с несколькими страницами.
        Else
            PageNumber1 = spl(0)
            PageNumber2 = spl(1)
        End If
       
        '3) Запись в переменную начала начальной страницы.
        start_ = doc_act.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageNumber1).Start
       
        '4) Запись в переменную конца конечной страницы.
            ' Нужно в переменную записать начало следующей страницы после указанной конечной.
            ' Если конечная страница - это последняя страница, то запишем в переменную конец файла.
        If doc_act.ComputeStatistics(wdStatisticPages) = PageNumber2 Then
            end_ = doc_act.Range.End
        Else
            end_ = doc_act.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageNumber2 + 1).Start
        End If
       

        '5) Копирование страниц в новый файл.
       
        'a) Копирование страниц, которые находятся в исходном файле.
        ' Нужный пункт раскомментируйте, а ненужный закомментируйте.
        ' Копирование без выделения.
        doc_act.Range(start_, end_).Copy
'        ' Выделение и копирование выделенного.
'        doc_act.Range(start_, end_).Select
'        doc_act.ActiveWindow.Selection.Copy
       
        'b) Вставка в конец нового файла знака абзаца, чтобы вставляемый текст встал снизу.
        ' Проверка, может быть пустой абзац уже есть. Такое может быть например,
            ' если ворд-файл пустой, если в конце есть разрыв страниц, и наверное и в других случаях.
        If doc_new.Paragraphs.Last.Range.text <> Chr(13) Then
            doc_new.Range.InsertParagraphAfter
        End If
       
        'c) Вставка скопированных данных в конец нового файла.
            ' doc_new.Range.End - 1, doc_new.Range.End - 1) - это позиция перед самым последним знаком абзаца.
            ' .PasteAndFormat wdFormatOriginalFormatting - вставка исходного форматирования (то есть
                ' форматирования, которое имеет текст в исходном файле).
        doc_new.Range(doc_new.Range.End - 1, doc_new.Range.End - 1).PasteAndFormat wdFormatOriginalFormatting
       
    Next i
   
    '7. Очистка буфера обмена, чтобы при закрытии программы "Word" не было сообщения,
        ' что в буфере обмена содержится много данных. Для этого просто копируем любой один символ.
    doc_act.Characters(1).Copy
   
    '8. Включение монитора.
    Application.ScreenUpdating = True
   
    '9. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Function VerifyPagesNumbers(doc_act As Document, PagesNumbers) As Boolean

    ' Проверка, что юзер указал существующие номера страниц.
   
    Dim PageNumber1 As Long, PageNumber2 As Long
    Dim spl, i As Long


    For i = 0 To UBound(PagesNumbers)
       
        '1. Разбивка данных по дефису.
        spl = Split(PagesNumbers(i), "-")
       
        '2. Копирование номеров страниц из массива "spl" в две переменные.
        ' Если один элемент в массиве "spl", значит дефиса нет и нужно работать с одной страницей.
            ' При использовании функции "Split" создаётся массив, в котором у первого элемента
            ' порядковый номер 0.
        If UBound(spl) = 0 Then
            ' Запись в переменные номеров страниц, с которыми надо работать.
            PageNumber1 = spl(0)
            PageNumber2 = spl(0)
        ' Если есть дефис, значит нужно работать с несколькими страницами.
        Else
            PageNumber1 = spl(0)
            PageNumber2 = spl(1)
        End If
       
        '3. Проверка, что указанная начальная страница существует.
        If doc_act.ComputeStatistics(wdStatisticPages) < PageNumber1 Then
            Application.ScreenUpdating = True
            MsgBox "В файле нет страницы: " & PageNumber1, vbExclamation
            Exit Function
        End If
       
        '4. Проверка, что указанная конечная страница существует.
        If doc_act.ComputeStatistics(wdStatisticPages) < PageNumber2 Then
            Application.ScreenUpdating = True
            MsgBox "В файле нет страницы: " & PageNumber2, vbExclamation
            Exit Function
        End If
       
    Next i
       
    '5. Запись в переменную-функцию "VerifyPagesNumbers" слова True.
    VerifyPagesNumbers = True
       
End Function

Sub макрос()
   
    Dim doc_act As Document, doc_new As Document, PagesNumbers
    Dim start_ As Long, end_ As Long
    Dim spl, i As Long, ii As Long
   
   
    '1. Присваиваем активному файлу (это файл, который отображается на мониторе) имя "doc_act".
        ' После создания нового файла, активным файлом станет новый файл, и уже нельля
        ' будет обратиться к исходному активному файлу, используя объект "ActiveDocument".
    Set doc_act = ActiveDocument
   
    '2. Юзер указывает номера страниц с помощью инпутбокса.
    Do
   
        ' Defaul  - если юзер укажет неправильные данные, чтобы в инпутбоксе были
            ' отображены ранее введённые данные.
        PagesNumbers = InputBox(Prompt:="Укажите номера страниц. Пример: 1,3,5-7.", Default:=PagesNumbers)
        ' Если юзер щёлкнул "Cancel".
        If PagesNumbers = "" Then
            Exit Sub
        End If
        ' Разбивка номеров страниц по запятым, чтобы получился массив.
        PagesNumbers = Split(PagesNumbers, ",")
       
        ' Проверка, что юзер правильно записал номера страниц.
        If VerifyInputData(PagesNumbers) = False Then
            GoTo metka_NextInput
        End If
       
        ' Проверка, что юзер указал существующие номера страниц.
        If VerifyPagesNumbers(doc_act, PagesNumbers) = True Then
            Exit Do
        End If
       
metka_NextInput:
        ' Объединение в одну строку, чтобы подставить в инпутбокс.
        PagesNumbers = Join(PagesNumbers, ",")
       
    Loop
   
    '3. Отключение монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '4. Создание нового пустого файла и присваивание ему имени "doc_new".
    Set doc_new = Documents.Add
   
    '5. Копирование указанных страниц в новый файл.
        ' При использовании функции "Split" создаётся массив, в котором у первого элемента
        ' порядковый номер 0.
    For i = 0 To UBound(PagesNumbers)
       
        '1) Разбивка данных по дефису.
        spl = Split(PagesNumbers(i), "-")
       
        '2) Вставка в конец нового файла знака абзаца, чтобы вставляемый текст встал снизу.
        ' Проверка, может быть пустой абзац уже есть. Такое может быть например,
            ' если ворд-файл пустой, если в конце есть разрыв страниц, и наверное и в других случаях.
        If doc_new.Paragraphs.Last.Range.text <> Chr(13) Then
            doc_new.Range.InsertParagraphAfter
        End If
           
        For ii = spl(0) To spl(UBound(spl))
       
            '3) Запись в переменную начала страницы.
            start_ = doc_act.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=ii).Start
           
            '4) Запись в переменную конца страницы.
                ' Нужно в переменную записать начало следующей страницы после указанной.
                ' Если указанная страница - это последняя страница, то запишем в переменную конец файла.
            If doc_act.ComputeStatistics(wdStatisticPages) = ii Then
                end_ = doc_act.Range.End
            Else
                end_ = doc_act.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=ii + 1).Start
            End If
           
   
            '5) Копирование страниц в новый файл.
           
            'a) Копирование страницы, которая находится в исходном файле.
            ' Нужный пункт раскомментируйте, а ненужный закомментируйте.
            ' Копирование без выделения.
            doc_act.Range(start_, end_).Copy
    '        ' Выделение и копирование выделенного.
    '        doc_act.Range(start_, end_).Select
    '        doc_act.ActiveWindow.Selection.Copy
           
            'c) Вставка скопированных данных в конец нового файла.
                ' doc_new.Range.End - 1, doc_new.Range.End - 1) - это позиция перед самым последним знаком абзаца.
                ' .PasteAndFormat wdFormatOriginalFormatting - вставка исходного форматирования (то есть
                    ' форматирования, которое имеет текст в исходном файле).
            doc_new.Range(doc_new.Range.End - 1, doc_new.Range.End - 1).PasteAndFormat wdFormatOriginalFormatting
       
        Next ii
       
    Next i
   
    '6. Очистка буфера обмена, чтобы при закрытии программы "Word" не было сообщения,
        ' что в буфере обмена содержится много данных. Для этого просто копируем любой один символ.
    doc_act.Characters(1).Copy
   
    '7. Включение монитора.
    Application.ScreenUpdating = True
   
    '8. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Function VerifyInputData(PagesNumbers) As Boolean

    ' Проверка, что юзер правильно записал номера страниц.
        ' Проверка, что кроме запятой, дефиса и цифр нет других символов.
        ' Пробелы тоже могут быть, но лучше их не надо указывать.
   
    Dim spl, i As Long, ii As Long
   
    For i = 0 To UBound(PagesNumbers)
        ' Разбивка по дефису.
        spl = Split(PagesNumbers(i), "-")
        For ii = 0 To UBound(spl)
            ' Если это не число, то выход из функции.
            If IsNumeric(spl(ii)) = False Then
                Application.ScreenUpdating = True
                MsgBox "Введены неправильные данные.", vbExclamation
                Exit Function
            End If
        Next ii
    Next i
   
    ' Запись в переменную-функцию "VerifyInputData" слова "True".
    VerifyInputData = True
   
End Function

Private Function VerifyPagesNumbers(doc_act As Document, PagesNumbers) As Boolean

    ' Проверка, что юзер указал существующие номера страниц.
   
    Dim PageNumber1 As Long, PageNumber2 As Long
    Dim spl, i As Long


    For i = 0 To UBound(PagesNumbers)
       
        '1. Разбивка данных по дефису.
        spl = Split(PagesNumbers(i), "-")
       
        '2. Копирование номеров страниц из массива "spl" в две переменные.
        ' Если один элемент в массиве "spl", значит дефиса нет и нужно работать с одной страницей.
            ' При использовании функции "Split" создаётся массив, в котором у первого элемента
            ' порядковый номер 0.
        If UBound(spl) = 0 Then
            ' Запись в переменные номеров страниц, с которыми надо работать.
            PageNumber1 = spl(0)
            PageNumber2 = spl(0)
        ' Если есть дефис, значит нужно работать с несколькими страницами.
        Else
            PageNumber1 = spl(0)
            PageNumber2 = spl(1)
        End If
       
        '3. Проверка, что указанная начальная страница существует.
        If doc_act.ComputeStatistics(wdStatisticPages) < PageNumber1 Then
            Application.ScreenUpdating = True
            MsgBox "В файле нет страницы: " & PageNumber1, vbExclamation
            Exit Function
        End If
       
        '4. Проверка, что указанная конечная страница существует.
        If doc_act.ComputeStatistics(wdStatisticPages) < PageNumber2 Then
            Application.ScreenUpdating = True
            MsgBox "В файле нет страницы: " & PageNumber2, vbExclamation
            Exit Function
        End If
       
    Next i
       
    '5. Запись в переменную-функцию "VerifyPagesNumbers" слова True.
    VerifyPagesNumbers = True
       
End Function