1

Тема: Макрос для поиска определённого объекта в формуле

Целый день угрохал чтобы найти похожие макросы и изучить комманды но время поджимает. Подскажите пожалуйста. Правда это не эксель а ворд

Я преподаватель. студенты присылают работы с заменой слов на формулы Eq
Я очищал эти формулы с помощью макроса:

Sub Макрос()
Dim fld As Field, i As Long


'1. Скрытие кодов полей, если вдруг юзер их отобразил для каких-то своих целей.
ActiveWindow.View.ShowFieldCodes = False

For i = ActiveDocument.Fields.Count To 1 Step -1

'2. Присваивание программного имени полю.
Set fld = ActiveDocument.Fields(i)

' Если это eq-поле.
If fld.Type = wdFieldFormula Then
'3. Выделение поля (с помощью Range не получилось работать).
fld.Select
'4. Копирование поля.
Selection.Copy
'5. Вставка поля в виде текста.
Selection.PasteAndFormat (wdFormatPlainText)
End If

Next i

'5. Сообщение, чтобы юзер понял, что макрос закончил работу.
MsgBox "Готово.", vbInformation

End Sub

Но студенты начали вставлять в формулы ещё уплотнённый текст. т.е. теперь они к оригинальному слову добавлят синонимы и получается 3-4 слова, и синонимы делают уплотнением чтобы буквы в один ряд, и закрашивают белым цветом, а оригинальный текст остаётся обычным и всё это в формулу форматируют.

В итоге когда прогоняю через макрос текст, то содержимое формул(слова) все форматируются в одно уплотнённый символ.

Т.е. мне нужно убрать только синонимы, оригинальное слово оставить и убрать естественно потом форматирование формулой.

Сейчас я вроде как решил вопрос. Сначала я нажимаю на всём тексте правой кнопкой мыши и выбираю "коды\значения полей" для того чтобы можно было формулу редактировать.

Потом запускаю вот такой макрос:

   

Selection.Find.ClearFormatting

   With Selection.Find.Font

       .Spacing = -100

       .Scaling = 1

   End With

   Selection.Find.Replacement.ClearFormatting

   With Selection.Find

       .Text = ""

       .Replacement.Text = ""

       .Forward = True

       .Wrap = wdFindContinue

       .Format = True

       .MatchCase = False

       .MatchWholeWord = False

       .MatchWildcards = False

       .MatchSoundsLike = False

       .MatchAllWordForms = False

   End With

   Selection.Find.Execute

End Sub

Т.е. очищаю сначала от синонимов уплотнённых и потом предыдущим макросом всё подчищаю. НО! Вот этот последний макрос будет работать только если он два раза будет цикл делать на одном слове. Т.е. если к примеру через поиск искать уплотнённый текст, нажимаю поиск, - находит. Потом нажимаю ещё раз поиск и уже в этой формуле состоящей из двух синонимов и оригинального слова поиск акцент кидает именно на синонимы. И потом я могу удалить только синонимы.

Так вот как сделать чтобы макрос два раза цикл запускал за один шаг

2

Re: Макрос для поиска определённого объекта в формуле

Просто если не сложно  подскажите куда копать. Потому что когда нажимаю два раза Найти далее, то сначала находит слово (формулу) а потом в этой формуле по второму нажатию поиск находит синонимы эти и если нажать третий раз то переходит к следующему слову и так же находит дальше синонимы эти.

Т.е. мне просто нужно в макросе отобразить это грамотно. Я пробовал через запись. Но у меня просто повторялась команда:

Selection.Find.Execute

Но при выполнении, макроса,  синонимы не выделялись

3

Re: Макрос для поиска определённого объекта в формуле

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

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

4

Re: Макрос для поиска определённого объекта в формуле

merlak пишет:

Но студенты начали вставлять в формулы ещё уплотнённый текст. т.е. теперь они к оригинальному слову добавлят синонимы и получается 3-4 слова, и синонимы делают уплотнением чтобы буквы в один ряд, и закрашивают белым цветом, а оригинальный текст остаётся обычным и всё это в формулу форматируют.

выложите пример документа --я такого еще не видела

5

Re: Макрос для поиска определённого объекта в формуле

shanemac51 пишет:

выложите пример документа --я такого еще не видела

Странно, но такое постоянно встречается. У меня даже просили что-то такое сделать big_smile

Post's attachments

Doc1.doc 22 Кб, 13 скачиваний с 2018-06-11 

You don't have the permssions to download the attachments of this post.
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

6

Re: Макрос для поиска определённого объекта в формуле

просто формулы я видела часто, я не видела синонимов в формуле

7

Re: Макрос для поиска определённого объекта в формуле

Кстати странно, но у меня уплотнённость не осталась. Сбрасывайте документ big_smile
Но, честно говоря, если ставить текст без пробелов и присоединять к отображаемому - то ничего толком не сделаешь - можно уповать только на словарь ворда.
Используем вот этот код:

Sub Макрос()
Dim fChecking As SpellingSuggestions
Dim oSug As SpellingSuggestion
Dim bCheck As Boolean
Dim fld As Field, i As Long
'1. Скрытие кодов полей, если вдруг юзер их отобразил для каких-то своих целей.
ActiveWindow.View.ShowFieldCodes = False
For i = ActiveDocument.Fields.Count To 1 Step -1
    '2. Присваивание программного имени полю.
    Set fld = ActiveDocument.Fields(i)
    ' Если это eq-поле.
    If fld.Type = wdFieldFormula Then
        '3. Выделение поля (с помощью Range не получилось работать).
        fld.Select
        '4. Копирование поля.
        Selection.Copy
        sText = fld.Code
        iLen = Len(sText)
        '5. Вставка поля в виде текста.
        Selection.PasteAndFormat (wdFormatPlainText)
        Selection.MoveLeft Unit:=wdCharacter, Count:=iLen
        Selection.Expand Unit:=wdWord
        If Len(Trim(Selection.Range.Text)) = iLen Then
            bCheck = False
            iSelect = iLen + 1
            For y = 1 To iLen
                iSelect = iSelect - 1
                Selection.MoveLeft Unit:=wdCharacter, Count:=iSelect, Extend:=wdExtend
                sSelected = Selection.Range.Text
                Set fChecking = GetSpellingSuggestions(Word:=sSelected, SuggestionMode:=wdSpellword)
                If fChecking.Count <> 0 Then
                    MsgBox "Слово существует"
                    For Each oSug In fChecking
                        MsgBox oSug.Name
                        bCheck = CheckThisSug(oSug.Name)
                        If bCheck = True Then GoTo ExitLine
                    Next oSug
                        If bCheck = False Then GoTo ContinueLine
                Else
ContinueLine:
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.MoveLeft Unit:=wdCharacter, Count:=1
                End If
            Next y
        Else
            iNewLen = Len(Trim(Selection.Range.Text))
            Selection.Collapse Direction:=wdCollapseStart
            Selection.MoveRight Unit:=wdCharacter, Count:=iNewLen
            Selection.MoveRight Unit:=wdCharacter, Count:=iLen - iNewLen, Extend:=wdExtend
            Selection.Range.Delete
            iLen = iNewLen
            iSelect = iNewLen + 1
            For Z = 1 To iLen
                iSelect = iSelect - 1
                Selection.MoveLeft Unit:=wdCharacter, Count:=iSelect, Extend:=wdExtend
                sSelected = Selection.Range.Text
                Set fChecking = GetSpellingSuggestions(Word:=sSelected, SuggestionMode:=wdSpellword)
                If fChecking.Count <> 0 Then
                    'MsgBox "Слово существует"
                    For Each oSug In fChecking
                        MsgBox oSug.Name
                        bCheck = CheckThisSug(oSug.Name)
                        If bCheck = True Then GoTo ExitLine
                    Next oSug
                        If bCheck = False Then GoTo ContinueLine2
                Else
ContinueLine2:
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.MoveLeft Unit:=wdCharacter, Count:=1
                End If
            Next Z
        End If
    End If
Next i

ExitLine:
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveRight Unit:=wdCharacter, Count:=iLen, Extend:=wdExtend
Selection.Range.Text = oSug.Name
'5. Сообщение, чтобы юзер понял, что макрос закончил работу.
MsgBox "Готово.", vbInformation
End Sub
Function CheckThisSug(ByVal sName As String) As Boolean
    If InStr(sName, Chr(32)) >= 1 Then
        CheckThisSug = False
    Else
        CheckThisSug = True
    End If
End Function

Извините, что не в функцией, а повтор два раза цикла, но решение пришло во время разработки, а переписывать было лень)

Если всё же по-божески всё сделали студенты, и после основного слова есть пробел, то вам достаточно будет этого куска

Sub Макрос()
Dim fld As Field, i As Long
'1. Скрытие кодов полей, если вдруг юзер их отобразил для каких-то своих целей.
ActiveWindow.View.ShowFieldCodes = False
For i = ActiveDocument.Fields.Count To 1 Step -1
    '2. Присваивание программного имени полю.
    Set fld = ActiveDocument.Fields(i)
    ' Если это eq-поле.
    If fld.Type = wdFieldFormula Then
        '3. Выделение поля (с помощью Range не получилось работать).
        fld.Select
        '4. Копирование поля.
        Selection.Copy
        sText = fld.Code
        iLen = Len(sText)
        '5. Вставка поля в виде текста.
        Selection.PasteAndFormat (wdFormatPlainText)
        Selection.MoveLeft Unit:=wdCharacter, Count:=iLen
        Selection.Expand Unit:=wdWord
        sWord = Trim(Selection.range.text)
        Selection.Collapse Direction:=wdCollapseStart
        Selection.MoveRight Unit:=wdCharacter, Count:=Len(sWord)
        Selection.MoveRight Unit:=wdCharacter, Count:=iLen - Len(sWord), Extend:=wdExtend
        Selection.Range.Delete
'5. Сообщение, чтобы юзер понял, что макрос закончил работу.
MsgBox "Готово.", vbInformation
End Sub
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

8

Re: Макрос для поиска определённого объекта в формуле

    End If
Next i

ещё добавить перед пятым пунктом второго варианта.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

9

Re: Макрос для поиска определённого объекта в формуле

Пробуйте.
Макрос преобразует поля в форматированный текст, затем ищет по всему тексту символы, для которых форматирование шрифта - уплотнённый текст или цвет шрифта белый  и удаляет эти символы

Sub CleanAntiPlagiat()
'
Dim orng As Range, i As Long, fld As Field

For i = ActiveDocument.Fields.Count To 1 Step -1
    Set fld = ActiveDocument.Fields(i)
    
'  Обрабатываем eq-поле.
    If fld.Type = wdFieldFormula Then
        fld.ShowCodes = True
        Set orng = fld.Code
        orng.Start = orng.Start + 3
        orng.End = orng.End - 1
        orng.Copy
        fld.Delete
        orng.Paste
    End If
Next i
    
    Set orng = ActiveDocument.Content
    orng.Find.ClearFormatting
    orng.Find.Replacement.ClearFormatting
    With orng.Find
        .Text = "^?"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        
        Do While .Execute
           If orng.Font.Spacing < 0 Or orng.Font.Color = wdColorWhite Then orng.Delete
        Loop
        
    End With
End Sub 

10

Re: Макрос для поиска определённого объекта в формуле

Так даже лучше) Что-то я ерундой занялся - решил сделать как автор)

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

11

Re: Макрос для поиска определённого объекта в формуле

Fck_This пишет:
shanemac51 пишет:

выложите пример документа --я такого еще не видела

Странно, но такое постоянно встречается. У меня даже просили что-то такое сделать big_smile

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

12

Re: Макрос для поиска определённого объекта в формуле

Добрый день. Извините что поднимаю старую тему. Но она сейчас актуальна. Можно сделать макрос не удаления полей и сжатого текста, а наоборот чтоб получить результат как в файле примере   Doc1.doc 22 Кб.