Страницы: 1
RSS
VBA: избавиться от повтора одинаковой функции
 
Добрый день. У меня есть код, который выполняет поиск слов "по их окружению" в Word файле с помощью макроса в Excel и вставляет их в определенные ячейки. Но код повторяет одну и ту же функцию поиска несколько раз:
Код
'''Наименование дисциплины'''
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "дисциплина *относится"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 11, r.End - 9).Copy
                Range("C4").Select
                Range("B4").Value = "Название дисциплины"
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
            Else
                Exit Do
            End If
        End With
    Loop

'''Цель'''
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "дисциплины – * сформировать"
    .Forward = True    
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 13, r.End - 13).Copy
                Range("C6").Select
                Range("B6").Value = "Цель дисциплины"
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
            Else
                Exit Do
            End If
        End With
    Loop
   
End Sub

Как мне сократить этот код (избавиться от повтора функции)?
Изменено: Alex375 - 04.06.2018 16:27:47
 
Если надо обрабатывать сразу много файлов Word, могу посоветовать использовать другой макрос
можете загуглить фразу парсер файлов Word

а по вашему коду, - можно просто после строки
Код
ActiveSheet.Paste

добавить строку
Код
Exit Do
 
Я наверное неправильно написал, мне нужно чтобы для каждого нового поиска слова, надо было не копировать и вставлять заново этот кусок кода:  
Код
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "дисциплина *относится"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 11, r.End - 9).Copy
                Range("C4").Select
                Range("B4").Value = "Название дисциплины"
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
            Else
                Exit Do
            End If
        End With
    Loop
А чтобы поиск был только один, а разные данные для поиска:
Код
.Text = "дисциплина *относится"

и вставки:
Код
WordDoc.Range(r.Start + 11, r.End - 9).Copy                
Range("C4").Select
Range("B4").Value = "Название дисциплины"
ActiveSheet.Paste
Заносились бы туда автоматически.
 
Код
Set r = WordDoc.Range
arrText = Worksheets("Slovar").Range("A1:A10").Value

For i = Lbound(arrText) To Ubound(arrText)
With r.Find
    .ClearFormatting
    .Text = arrText(i, 1)
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 11, r.End - 9).Copy
                Range("C4").Select
                Range("B4").Value = "Название дисциплины"
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
   
            End If
        End With
  Next i


Как то так.
Где Worksheets("Slovar").Range("A1:A10").Value - адрес диапазона с перечнем искомых фраз.
Аналогично можете добавить диапазон с заголовками и адреса вставки привязать к i
Страницы: 1
Наверх