Sub PageReference()
Dim oDoc As Document
Dim oNewDoc As Document
Dim oField As Field
Dim sName, sFullName As String
Dim iPageNumber, iNumPages, i, y As Integer
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
sName = oDoc.Name
sFullName = oDoc.FullName
Set oNewDoc = Application.Documents.Add(Visible:=True)
oDoc.Activate
iNumPages = oDoc.Range.ComputeStatistics(wdStatisticPages)
For i = 1 To iNumPages
For y = 1 To iNumPages
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=y, Name:=""
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
If Selection.Range.Fields.Count <> 0 Then
For Each oField In Selection.Range.Fields
sCode = oField.Code
sText = oField.Result
If InStr(sCode, "Page") >= 1 Then
If CInt(sText) = i Then
oField.Select
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=y, Name:=""
iPageNumber = Selection.Information(wdActiveEndPageNumber)
Call SelectIt(iPageNumber)
Application.StatusBar = "Копируем " & y & "-ю страницу": DoEvents
Selection.Range.Copy
oNewDoc.Activate
Selection.EndKey Unit:=wdStory, Extend:=wdMove
If i <> 1 Then Selection.InsertAfter Chr(32)
Selection.Collapse Direction:=wdCollapseEnd
Selection.Paste
oDoc.Activate
GoTo FindNext
End If
End If
Next oField
End If
Next y
FindNext:
Next i
oNewDoc.SaveAs2 FileName:=Replace(sFullName, sName, "Готовая книга " & Date & ".doc")
oNewDoc.Close SaveChanges:=wdSaveChanges
Application.ScreenUpdating = True
MsgBox "Прошли все страницы"
End Sub
Private Sub SelectIt(ByVal iPageNumber As Integer)
Dim oDoc As Document
Dim iNext As Integer
Dim oRange As Range
iNext = iPageNumber + 1
Set oDoc = ActiveDocument
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=iPageNumber, Name:=""
Selection.MoveRight Unit:=wdCharacter, Count:=10, Extend:=wdExtend
Set oRange = Selection.Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=iNext, Name:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=10, Extend:=wdExtend
oRange.SetRange Start:=oRange.Start, End:=Selection.Range.End
oRange.Select
End Sub
Интересно было как обращаться к полю в колонтитула на каждой странице - вот это написал. А вам надо в тексте искать, я думаю. Но по вашему примеру ничего не понять.
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871