1

Тема: Поиск по ключевым словам

Есть файл с большим объемом текста и есть куча ключевых слов, которые нужно найти и выделить цветом. Если искать по одному слову, то уйдет очень много времени. Каким способом можно найти несколько слов одновременно?

2

Re: Поиск по ключевым словам

Johnny Bravo пишет:

Есть файл с большим объемом текста и есть куча ключевых слов, которые нужно найти и выделить цветом. Если искать по одному слову, то уйдет очень много времени. Каким способом можно найти несколько слов одновременно?

Попробуйте методику, изложенную в посте http://wordexpert.ru/forum/viewtopic.php?id=3044

3

Re: Поиск по ключевым словам

Как-то все сложно. Еще вопрос: есть текстовый файл объявлений с номерами телефонов, формата 8-926-000-00-00, можно выделить повторяющиеся номера телефонов более 3-х раз? word 2016

4

Re: Поиск по ключевым словам

Johnny Bravo пишет:

Как-то все сложно. Еще вопрос: есть текстовый файл объявлений с номерами телефонов, формата 8-926-000-00-00, можно выделить повторяющиеся номера телефонов более 3-х раз? word 2016

Можно выделить. Вы скажите только как выделять - Вот тут будет серым

Sub ВводКлючевыхСлов()
Dim sMass, sKeyWord As String
Dim iChoise As Integer
sMass = ""
InputLine:
sKeyWord = InputBox("Введите ключевое слово.")
    If Not sMass = "" Then sMass = sMass & ", " & sKeyWord
    If sMass = "" Then sMass = sKeyWord
iChoise = MsgBox(Prompt:=sMass & ". Ввести ещё слова?", Buttons:=vbYesNo, Title:="Ваши ключевые слова:")
    If iChoise = 6 Then
        GoTo InputLine
    ElseIf iChoise = 7 Then
        Call Маркировка(sMass)
    End If
End Sub
Private Sub Маркировка(ByVal sMass As String)
Dim i
Options.DefaultHighlightColorIndex = wdGray25
    sMass = Replace(sMass, Chr(32), "")
    aMyArray = Split(sMass, ",")
For i = LBound(aMyArray) To UBound(aMyArray)
iFirst = 0
Selection.HomeKey Unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .Text = aMyArray(i)
    Do While .Execute = True
        If ActiveDocument.Range(1, Selection.End).Characters.Count = iFirst Then GoTo NextKey
            'HighLightColorIndex можно выбрать на своё усмотрение
        If iFirst = 0 Then iFirst = ActiveDocument.Range(1, Selection.End).Characters.Count
        If Selection.Range.HighlightColorIndex = 0 Then: Selection.Range.HighlightColorIndex = wdGray25
    Loop
End With
NextKey:
    iFirst = 0
Next i
Selection.HomeKey Unit:=wdStory
End Sub
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

5

Re: Поиск по ключевым словам

Johnny Bravo пишет:

Как-то все сложно. Еще вопрос: есть текстовый файл объявлений с номерами телефонов, формата 8-926-000-00-00, можно выделить повторяющиеся номера телефонов более 3-х раз? word 2016

Запускать нужно макросы "ПокраскаНомеров" и "ВводКлючевыхСлов". Можно было бы процедуру покраски совместить в 1, с передачей цвета, но мне лень уже.

Sub ПокраскаНомеров()
Dim sFindText, sSaver, sPrepare As String
Dim iCounter, iLowBound As Integer
Dim iNumber As Variant
Dim aDbl_Array As Variant
Selection.HomeKey Unit:=wdStory
ReDim aDbl_Array(1, 0)
sFindText = "[0-9]-[0-9]{3}-[0-9]{3}-[0-9]{2}-[0-9]{2}"
'"[0-9][-][0-9]{3}[-][0-9]{3}[-][0-9]{2}[-][0-9]{2}"
iCounter = 0
    With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = sFindText
    Do While .Execute = True
        sSaver = Selection.Text
        If aDbl_Array(0, 0) = Empty Then
            aDbl_Array(0, 0) = sSaver: aDbl_Array(1, 0) = 1
        Else
            iNumber = CheckIt(aDbl_Array, sSaver)
'iNumber = натуральное число - в Массиве есть такой элемент, iNumber = 999999 - нету
            If iNumber = 999999 Then
                iLowBound = UBound(aDbl_Array, 2) + 1
                ReDim Preserve aDbl_Array(1, iLowBound)
                aDbl_Array(0, iLowBound) = sSaver: aDbl_Array(1, iLowBound) = 1
            Else
                iCounter = aDbl_Array(1, iNumber): iCounter = iCounter + 1
                aDbl_Array(1, iNumber) = iCounter
            End If
        End If
    Loop
    End With
sPrepare = Упрощение(aDbl_Array)
Call МаркировкаНомеров(sPrepare)
End Sub
Private Function CheckIt(ByVal aDbl_Array As Variant, ByVal sSaver As String) As Variant
Dim i As Integer
    For i = LBound(aDbl_Array, 2) To UBound(aDbl_Array, 2)
        If sSaver Like aDbl_Array(0, i) Then: CheckIt = i: Exit Function
    Next i
CheckIt = 999999
End Function
Private Function Упрощение(ByVal aDbl_Array As Variant)
Dim i, iTopBound As Integer
Dim aNumberArray As Variant
ReDim aNumberArray(0)
For i = LBound(aDbl_Array, 2) To UBound(aDbl_Array, 2)
    If aDbl_Array(1, i) > 3 Then
        If Not aNumberArray(0) = Empty Then
            iTopBound = UBound(aNumberArray) + 1
            ReDim Preserve aNumberArray(iTopBound)
            aNumberArray(iTopBound) = aDbl_Array(0, i)
        End If
        If aNumberArray(0) = Empty Then aNumberArray(0) = aDbl_Array(0, i)
    End If
Next i
    Упрощение = Join(aNumberArray, ", ")
End Function
Private Sub МаркировкаНомеров(ByVal sPrepare As String)
Dim i
Options.DefaultHighlightColorIndex = wdYellow
    sMass = Replace(sPrepare, Chr(32), "")
    aMyArray = Split(sPrepare, ",")
For i = LBound(aMyArray) To UBound(aMyArray)
iFirst = 0
Selection.HomeKey Unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .Text = aMyArray(i)
    Do While .Execute = True
        If ActiveDocument.Range(1, Selection.End).Characters.Count = iFirst Then GoTo NextKey
            'HighLightColorIndex можно выбрать на своё усмотрение
        If iFirst = 0 Then iFirst = ActiveDocument.Range(1, Selection.End).Characters.Count
        If Selection.Range.HighlightColorIndex = 0 Then: Selection.Range.HighlightColorIndex = wdYellow
    Loop
End With
NextKey:
    iFirst = 0
Next i
Selection.HomeKey Unit:=wdStory
End Sub
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

6

Re: Поиск по ключевым словам

Fck_This, огромнейшее человеческое спасибо!