VBA - Разделение документа Word по 2 страницы

Внимание, важное сообщение: Дорогие Друзья!
В ноябре далекого 2001 года мы решили создать сайт и форум, которые смогут помочь как начинающим, так и продвинутым пользователям разобраться в операционных системах. В 2004-2006г наш проект был одним из самых крупных ИТ ресурсов в рунете, на пике нас посещало более 300 000 человек в день! Наша документация по службам Windows и автоматической установке помогла огромному количеству пользователей и сисадминов. Мы с уверенностью можем сказать, что внесли большой вклад в развитие ИТ сообщества рунета.

Но... время меняются, приоритеты тоже. И, к сожалению, пришло время сказать До встречи! После долгих дискуссий было принято решение закрыть наш проект. 1 августа форум переводится в режим Только чтение, а в начале сентября мы переведем рубильник в положение Выключен

Огромное спасибо за эти 24 года, это было незабываемое приключение. Сказать спасибо и поделиться своей историей можно в данной теме.

С уважением, ваш призрачный админ, BigMac...

VBA - Разделение документа Word по 2 страницы

WindBlow

Новый участник

Сообщения: 3
Благодарности: 0

Профиль | Отправить PM | Цитировать

Приветствую!
Подскажите, нашел рабочий код разделения документа постранично, но нужно чтобы разделялось по две страницы. Т.е. есть, например, документ из 100 страниц, нужно создать несколько двухстраничных со страницами 1-2, 3-4, ... , 99-100
Что нужно изменить в следующем коде?

Скрытый текст

PHP код:


Sub Split()

Dim docMultiple As Document

Dim docSingle As Document

Dim rngPage As Range

Dim iCurrentPage As Integer

Dim iPageCount As Integer

Dim strNewFileName As String

Application.ScreenUpdating = False

Set docMultiple = ActiveDocument

Set rngPage = docMultiple.Range

iCurrentPage = 1

iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)

Do Until iCurrentPage > iPageCount

If iCurrentPage = iPageCount Then

rngPage.End = ActiveDocument.Range.End

Else

Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1

rngPage.End = Selection.Start

End If

rngPage.Copy

Set docSingle = Documents.Add

docSingle.Range.Paste

docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""

strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")

docSingle.SaveAs strNewFileName

iCurrentPage = iCurrentPage + 1

docSingle.Close

rngPage.Collapse wdCollapseEnd

Loop

Application.ScreenUpdating = True

Set docMultiple = Nothing

Set docSingle = Nothing

Set rngPage = Nothing

End Sub

Пробовал менять значения рядом с iCurrentPage, но он то три страницы цеплял, то одну... К сожалению не сильно разбираюсь в VBA, извините...

Отправлено: 11:29, 20-05-2020

Iska

Ветеран

Сообщения: 27449
Благодарности: 8088

Профиль | Отправить PM | Цитировать

Не называйте собственные процедуры именами встроенных функций

Попробуйте так (не проверялось):

Скрытый текст

Код:

Option Explicit

Sub SplitBy2Pages()
    Dim docMultiple As Document
    'Dim docSingle As Document
    Dim rngPage As Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String
    
    Application.ScreenUpdating = False
    
    Set docMultiple = ActiveDocument
    Set rngPage = docMultiple.Range
    
    iCurrentPage = 1
    iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
    
    Do Until iCurrentPage > iPageCount
        If iCurrentPage = iPageCount Then
            rngPage.End = ActiveDocument.Range.End
        Else
            Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 2
            rngPage.End = Selection.Start
        End If
        
        rngPage.Copy
        
        With Documents.Add
            .Range.Paste
            '.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
            strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
            .SaveAs strNewFileName
            iCurrentPage = iCurrentPage + 2
            .Close
        End With
        
        rngPage.Collapse wdCollapseEnd
    Loop
    
    Application.ScreenUpdating = True
    
    Set docMultiple = Nothing
    Set docSingle = Nothing
    Set rngPage = Nothing
End Sub