1

Тема: VBA Find c циклом

Добрый день, уважаемые форумчане.
Вопрос в следующем.
Есть код, который ищет в Word циклом все значения в скобках к примеру [01tr01] и заменяет их из файла Эксель на значения. При использовании цикла Do while loop если ошибься в значении к примеру [01tr00] и Excel не находит этого значения, то получется бесконечный цикл.
Подскажите пожалуйста как можно по другому реализовать цикл, или обработать ненайденные значения.
Заранее спасибо.

Sub Find2()
Dim oFile, wsSh As Worksheet, Openbook, Book
Set wsh = CreateObject("WScript.Shell")
docs = wsh.SpecialFolders("Desktop") 'получение адреса рабочего стола
CurrentPath = ThisWorkbook.Path ' получение адреса текущей папки
Form = "Юр _форм _автозамена.doc"
Set obook = Workbooks.Open(docs & "\" & "crm_ui_frame(1)") ' имя книги по умолчанию
         Dim oWord As Word.Application
            Dim oDoc As Word.Document
            Set oWord = CreateObject("Word.Application")
            Set oDoc = oWord.Documents.Add(CurrentPath & "\" & Form) 'запускаем форму
            oWord.Visible = True
            oWord.Tasks("Microsoft Word").Activate
            'oWord.Application.ScreenUpdating = False
           ' thisdocument.Activate
Set myRange = oDoc.Content
     myRange.Find.ClearFormatting
    With myRange.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
            Do While .Found = True
                'MsgBox myRange
                .Execute
                Codes = Mid(myRange, 2, Len(myRange) - 2)
     Set sRow = Cells.Find(What:=Codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oDoc.Content.Find.ClearFormatting
   With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
Else:
myRange.HighlightColorIndex = wdRed
Exit Sub
 End If
  Loop
End With
End Sub

2

Re: VBA Find c циклом

В выложенном Вами макросе очень много ошибок:
1. Некорректно объявлены переменные.
2. Некорректно объявлен объект Word.
3. Выложите образец файла Word и Excel, чтобы дать рекомендации по алгоритму решения Вашего вопроса.

3

Re: VBA Find c циклом

Если не трудно, посмотрите пожалуйста, прикладываю файл
crm_ui_frame(1) - должен лежать на рабочем столе
Книга с макросом и Юр _форм _автозамена - должны лежать в одной папке.
Запускается макрос из книги - книга с макросом
Заранее спасибо

Post's attachments

форум.zip 67.25 Кб, 4 скачиваний с 2012-09-18 

You don't have the permssions to download the attachments of this post.

4

Re: VBA Find c циклом

Файлы получил, опишите конкретнее что Вы хотите получить в результате работы макроса.

5

Re: VBA Find c циклом

Есть шаблон в Word Юр _форм _автозамена.
В нем будут располагаются коды в скобочках [код], которые должны заменяться на значения из файла crm_ui_frame(1).  При прохождении циклом  шаблона если какие-нибудь коды не найдены в файле crm_ui_frame(1), то они выделяются красным в документе.
Файл с макросом- запускающий файл.

6

Re: VBA Find c циклом

Понятно, ждите ответа.

7

Re: VBA Find c циклом

Спасибо, решил таким способом.
Для тех кодов, которые не найдены [01tr00], скобки заменяются на кавычки "01tr00".
В итоге макрос прекрасно все отрабатывает.

Sub Find2()
Dim oFile, wsSh As Worksheet, Openbook, Book
Set wsh = CreateObject("WScript.Shell")
docs = wsh.SpecialFolders("Desktop") 'ïîëó÷åíèå àäðåñà ðàáî÷åãî ñòîëà
CurrentPath = ThisWorkbook.Path ' ïîëó÷åíèå àäðåñà òåêóùåé ïàïêè
Form = "Þð _ôîðì _àâòîçàìåíà.doc"
Set obook = Workbooks.Open(docs & "\" & "crm_ui_frame(1)") ' èìÿ êíèãè ïî óìîë÷àíèþ
         Dim oWord As Word.Application
            Dim oDoc As Word.Document
            Set oWord = CreateObject("Word.Application")
            Set oDoc = oWord.Documents.Add(CurrentPath & "\" & Form) 'çàïóñêàåì ôîðìó
            oWord.Visible = True
            oWord.Tasks("Microsoft Word").Activate
            'oWord.Application.ScreenUpdating = False
           ' thisdocument.Activate
Set myRange = oDoc.Content
     myRange.Find.ClearFormatting
    With myRange.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
            Do
                'MsgBox myRange
                .Execute
                codes = Mid(myRange, 2, Len(myRange) - 2)
     Set sRow = Cells.Find(What:=codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oDoc.Content.Find.ClearFormatting
   With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
Else:
myRange.HighlightColorIndex = wdRed
codes = Mid(myRange, 2, Len(myRange) - 2)
With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Chr(34) & codes & Chr(34)
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
 End If
  Loop While .Found = True
End With
End Sub

8

Re: VBA Find c циклом

Вообще из присланных документов я понял, что файл crm_ui_frame(1) составляется на каждый договор, а значения Кодов в этого должно вставляться в документ Договора Word

9

Re: VBA Find c циклом

Соответственно и Word документ должен быть сохранен либо как Номер договора, либо как Фамилия Имя Отчество, либо и то и другое

10

Re: VBA Find c циклом

Насчет сохранения, подумаю, спасибо.
Можно еще вопрос, подскажите пожалуйста как можно заменить кода в колонтитулах?

11

Re: VBA Find c циклом

Так как колонтитулы относятся к разделам Документа Word, то доступ к ним осуществляется через объект Section к коллекциям Section.Footers и Section.Headers примеры:

With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
    .PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight
End With
ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
With ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
    .Range.InsertAfter("First Page Text")
    .Range.Paragraphs.Alignment = wdAlignParagraphRight
End With

12

Re: VBA Find c циклом

Просто у меня не получается Range.Find
Как-то по-другому организуется поиск в Колонтитулах?
Спасибо

13

Re: VBA Find c циклом

Вы не внимательно смотрели примеры:

With ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
    .Range.InsertAfter("First Page Text")
    .Range.Paragraphs.Alignment = wdAlignParagraphRight
End With

В этом коде открыт доступ к объекту Range Верхнего колонтитула 1-й страницы, 1-го раздела. Далее к нему можно применять метод Range.Find

Отредактировано aap77 (18.09.2012 14:36:34)

14

Re: VBA Find c циклом

Не могли бы Вы посмотреть на моем примере?
Никак не пойму в чем проблема.
Дописал функцию, через отладчик смотрю, что replacement правильный, но в колонтитуле вместо [код] получается  [значение значение часть кода], а не просто значение.

Sub Find2()
Dim oFile, wsSh As Worksheet, Openbook, Book
Set wsh = CreateObject("WScript.Shell")
docs = wsh.SpecialFolders("Desktop") 'получение адреса рабочего стола
CurrentPath = ThisWorkbook.Path ' получение адреса текущей папки
Form = "Юр _форм _автозамена.doc"
Set obook = Workbooks.Open(docs & "\" & "crm_ui_frame(1)") ' имя книги по умолчанию
         Dim oWord As Word.Application
            Dim oDoc As Word.Document
            Set oWord = CreateObject("Word.Application")
            Set oDoc = oWord.Documents.Add(CurrentPath & "\" & Form) 'запускаем форму
            oWord.Visible = True
            oWord.Tasks("Microsoft Word").Activate
            'oWord.Application.ScreenUpdating = False
           ' thisdocument.Activate
Set myRange = oDoc.Content
     myRange.Find.ClearFormatting
    With myRange.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
            Do While .Found = True
                'MsgBox myRange
                .Execute
                Codes = Mid(myRange, 2, Len(myRange) - 2)
     Set sRow = Cells.Find(What:=Codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oDoc.Content.Find.ClearFormatting
   With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
Else:
myRange.HighlightColorIndex = wdRed
Codes = Mid(myRange, 2, Len(myRange) - 2)
With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Chr(34) & Codes & Chr(34)
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
 End If
For k = 1 To oDoc.Sections.Count
    'Поиск в верхних колонтитулах
    For Each oHeadFtr In oDoc.Sections(k).Headers
     Call SearchInRange(oHeadFtr.Range)
    Next
    'Поиск в нижних колонтитулах
    For Each oHeadFtr In oDoc.Sections(k).Footers
    ' Call SearchInRange(oHeadFtr.Range, m:=Codes, k:=Values)
    Next
  Next
  Loop
End With
End Sub
Function SearchInRange(oRng) As Boolean
Set obook = Workbooks("crm_ui_frame(1)") ' имя книги по умолчанию
  With oRng.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
 Do While .Found = True
    .Execute
Codes = Mid(oRng, 2, Len(oRng) - 2)
Set sRow = Cells.Find(What:=Codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oRng.Find.ClearFormatting
   With oRng.Find
        .Text = oRng
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll
    End With
Else:
oRng.HighlightColorIndex = wdRed
Codes = Mid(oRng, 2, Len(oRng) - 2)
With oRng.Find
        .Text = oRng
        .Replacement.Text = Chr(34) & Codes & Chr(34)
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceOne, Forward:=True
    End With
 End If
 Loop
 End With
End Function

15

Re: VBA Find c циклом

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