Создание кнопки со своим VBA кодом

[Busine2009]

JuRMaN
Сделай следующее: Вид - Структура - Ctrl + А - На панели инструментов нажми "-" - перейди к последнему заголовку, посмотри, всё там свернулось или нет?

Ни разу не работал с сохранением, только завтра посмотрю. Ты же написал, что у тебя всё есть, я и не стал смотреть дальше.

[JuRMaN]

Да, там свернулось все. Кода у меня нет, только часть, и ту почерпнул из книги. Спасибо.

[Busine2009]

JuRMaN
тогда не знаю, в чём дело, у меня получилось, правда, у меня всего 2 заголовка.

[Busine2009]

JuRMaN

Код: Выделить всё

Sub HeadlinesCopyToTheDifferentFiles_2()
Dim vNumberOfHeadlines As Long
ActiveWindow.ActivePane.View.Type = wdMasterView
Selection.WholeStory
ActiveWindow.ActivePane.View.CollapseOutline Range:=Selection.Range
With ActiveDocument.Range.Find
    .Style = ActiveDocument.Styles("Заголовок 1")
    While .Execute
        vNumberOfHeadlines = 1 + vNumberOfHeadlines
        .Parent.Select
        Selection.MoveLeft
        Selection.EndKey Extend:=True
        Selection.Copy
        Documents.Add
        Selection.Paste
        Documents(1).SaveAs FileName:="E:\_Рабочий стол\Рабочая папка\" & vNumberOfHeadlines & "_Заголовок.doc"
        Documents(1).Close
    Wend
End With
End Sub

[Busine2009]

JuRMaN
Вот этот вариант подойдёт, если у тебя бардак в документе и стилем Заголовок 1 оформлено что нужно и что не нужно.
Но сначала тебе надо вставить перед каждым "Заголовком 1" разрыв раздела. Этот вариант плох тем, что в разные документы будут попадать части одного раздела, если, например, имеют разную ориентацию или размер.

Код: Выделить всё

Sub HeadlinesCopyToTheDifferentFiles_3()
Dim oSection As Section
Dim vNumberOfHeadlines As Long
For Each oSection In ActiveDocument.Sections
    vNumberOfHeadlines = 1 + vNumberOfHeadlines
    oSection.Range.Copy
    Documents.Add
    Selection.Paste
    Documents(1).SaveAs FileName:="E:\_Рабочий стол\Рабочая папка\" & vNumberOfHeadlines & "_Заголовок.doc"
    Documents(1).Close
Next
End Sub

[Busine2009]

JuRMaN
Вот ещё вариант, но он будет полезен, если в документе используются только Заголовки 1 уровня:

Код: Выделить всё

Sub CopyPartsOfDocumentToTheDocuments()
Dim vNumberOfHeadlines As Long
On Error GoTo metka_1
With ActiveDocument.Range.Find
    .Style = "Заголовок 1"
    While .Execute
            .Parent.Select
            Selection.ExtendMode = True
            Selection.GoTo what:=wdGoToHeading, which:=wdGoToNext
            Selection.Copy
            vNumberOfHeadlines = 1 + vNumberOfHeadlines
            Documents.Add
            Selection.Paste
            Documents(1).SaveAs FileName:="E:\_Рабочий стол\Рабочая папка\" & vNumberOfHeadlines & "_Заголовок.doc"
            Documents(1).Close
            GoTo metka_2
metka_1:
            vNumberOfHeadlines = 1 + vNumberOfHeadlines
            .Parent.Select
            Selection.EndKey Unit:=wdStory, Extend:=wdExtend
            Selection.Copy
            Documents.Add
            Selection.Paste
            Documents(1).SaveAs FileName:="E:\_Рабочий стол\Рабочая папка\" & vNumberOfHeadlines & "_Заголовок.doc"
            Documents(1).Close
metka_2:
    Wend
End With
End Sub

[ATTACH]1220[/ATTACH]
Ты можешь просматривать, что делает какая команда, открыв одновременно и документ Word и VBA и нажимать на кнопку, которая на рисунке.

[JuRMaN]

Busine2009
Спасибо огромное, сейчас буду все пробовать.
Вот что получилось, если необходимо добавить другие типы Заголовков (добавил Заголовок 2):
[html]
Sub CopyPartsOfDocumentToTheDocuments()
Dim vNumberOfHeadlines As Long
On Error GoTo metka_1
With ActiveDocument.Range.Find
.Style = "Заголовок 1"
While .Execute
.Parent.Select
Selection.ExtendMode = True
Selection.GoTo what:=wdGoToHeading, which:=wdGoToNext
Selection.Copy
vNumberOfHeadlines = 1 + vNumberOfHeadlines
Documents.Add
Selection.Paste
Documents(1).SaveAs FileName:="C:\путь\1" & vNumberOfHeadlines & "_Заголовок.doc"
Documents(1).Close
GoTo metka_2
metka_1:
vNumberOfHeadlines = 1 + vNumberOfHeadlines
.Parent.Select
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Copy
Documents.Add
Selection.Paste
Documents(1).SaveAs FileName:="C:\путь\1" & vNumberOfHeadlines & "_Заголовок.doc"
Documents(1).Close
metka_2:
Wend
End With
Dim vNumberOfHeadlines2 As Long
On Error GoTo metka_3
With ActiveDocument.Range.Find
.Style = "Заголовок 2"
While .Execute
.Parent.Select
Selection.ExtendMode = True
Selection.GoTo what:=wdGoToHeading, which:=wdGoToNext
Selection.Copy
vNumberOfHeadlines2 = 1 + vNumberOfHeadlines2
Documents.Add
Selection.Paste
Documents(1).SaveAs FileName:="C:\путь\2" & vNumberOfHeadlines2 & "_Заголовок.doc"
Documents(1).Close
GoTo metka_4
metka_3:
vNumberOfHeadlines2 = 1 + vNumberOfHeadlines2
.Parent.Select
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Copy
Documents.Add
Selection.Paste
Documents(1).SaveAs FileName:="C:\путь\2" & vNumberOfHeadlines2 & "_Заголовок.doc"
Documents(1).Close
metka_4:
Wend
End With
End Sub
[/html]