создание именного указателя

[shanemac51]

Код конечно сыроват, но для макета годится
Sub aword120314_0935()
Dim s1, s2, j1, J1A, j2, J2A, dt
Dim SS, SS1A, SS2A
Dim jcycl As Long
Dim dt1
Dim zkol As t_kol1
Dim kol00 As Collection
Dim XM1(32000, 2) As String
j1 = Word.ActiveDocument.Words.Count
dt1 = Now
Debug.Print j1, Len(Word.ActiveDocument.Content.Text)
dt = Timer
'Dim XM(32000) As String
SS = ""
 Word.ActiveDocument.Select
Debug.Print Selection.Information(wdNumberOfPagesInDocument)
Dim OBJLINES
Dim PAGE1 As Page, JP
Dim LINE1 As Line
Dim PANE1 As Pane
Set OBJLINES = ActiveDocument.ActiveWindow.Panes(1).Pages(1).Rectangles(1).Lines(1)
Debug.Print "=="; OBJLINES.Range.Text
Do While jcycl < 1
JP = 0

For Each PAGE1 In ActiveDocument.ActiveWindow.Panes(1).Pages
JP = JP + 1
PAGE1.Rectangles(1).Range.Select
J1A = Selection.Words.Count
j1 = 0
Do While j1 < J1A
j1 = j1 + 1
s2 = Selection.Words(j1)
j2 = Len(s2)
'Exit Do
'Debug.Print s2; " "; Len(SS)
If JP > 1 And Len(s2) > 12 Then
JP = JP + 0
End If
If j2 > 2 And InStr("QWERTYUIOPASDFGHJKLZXCVBNMЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮЁ", Mid(s2, 1, 1)) > 0 Then
'Debug.Print s2; " "; Len(SS);
j3 = InStr(SS, "`" & Trim(s2) & "`")
If j3 = 0 Then
SS = SS & "`" & Trim(s2) & "`"
Debug.Print s2; " "; Len(SS); JP; "="; DateDiff("s", Now, dt1)
If Len(SS) > 32000 Then
MsgBox "размер 32000 превышен ....нужна доработка макроса ...выхожу из WORD"
Word.Application.Quit True
Exit Sub
j3 = 0
End If

End If
j3 = InStr(SS, "`" & Trim(s2) & "`")
XM1(j3, 1) = Trim(s2)
SS1A = XM1(j3, 2)
'SS2A = " " & Trim(JP & "/") & Trim(jcycl) & " "
SS2A = " " & Trim(JP) & " "


If InStr(SS1A, SS2A) = 0 Then
XM1(j3, 2) = SS1A & SS2A
End If
'XM1(j3, 2) = XM1(j3, 2) & JP & "/" & j1 & ","
End If
'j1 = j1 - 1
Loop
Next PAGE1
Debug.Print jcycl, DateDiff("s", Now, dt1)
jcycl = jcycl + 1
Loop

j1 = 0
SS = ""
Do While j1 < 32000
j1 = j1 + 1
If Len(XM1(j1, 1)) > 0 Then
'Debug.Print j1, XM1(j1, 1), XM1(j1, 2)
SS1A = Trim(XM1(j1, 1)) & Chr(9)
SS = SS & Replace(SS1A & XM1(j1, 2), "  ", ", ") & Chr(13) & Chr(10)
End If
Loop
Word.Documents.Add
Selection.Range.Text = SS
Debug.Print dt - Timer
End Sub

хотела попробовать на чужом файле(справка по PureBasic) --не сработал
------------------------какие-то глюки-----------------------------------

[caute]

спасибо за труды, буду дерзать
надеюсь, символов окажется не слишком много (хотя сама книжка - около 2 млн. знаков).
может, разбить ее на части, если что?

доп. файлик сам причешу, как сумею.
ежели, конечно, сработает

[shanemac51]

я так и не поняла --какие слова вас интересуют

-фамилии-наименования
-или любое с заглавной буквы

[caute]

интересуют, конечно, фамилии (как русские, так и латиницей), но, по моему скромному разумению, фамилии от нефамилий можно отделить только вручную.
ну разве можно отделить макросом, например, "Коробочку" передач от старушки "Коробочки" из поэмы?

[shanemac51]

причем только из контекста

[caute]

Dim zkol As t_kol1

[shanemac51]

переведи строку в комментарий

[caute]

о! на пробном мелком файлике макрос сработал на ура
щас скормлю ему монстра

через 4 минуты работы выдал "размер превышен"
придется делить файл на куски...

готово, получилось три файла, которые надо слепить вместе, удалить лишние слова и дубли, потом каким-то образом выстроить номера страниц по порядку в пределах каждого абзаца (пока не придумал, как, - в крайнем случае доточу напильником).
спасибо вам, милая shanemac51, - макрос вполне рабочий

зы. вылетает он после обработки примерно 10 тыс. заглавных букв

[shanemac51]

выстроить номера страниц по порядку в пределах каждого абзаца

не поняла, что требуется

[caute]

допустим в списке дано:
Эйнштейн 100, 301
Эйнштейна 41, 252, 663
Эйнштейне 375

двух последних эйнштейнов убираю руками, цифры слепляю воедино, получается:
Эйнштейн 100, 301, 41, 252, 663, 375

но цифры-то не по порядку идут, а должны по порядку - так:
Эйнштейн 41, 100, 252, 301, 375, 663