Добрый день. У меня есть код, который выполняет поиск слов "по их окружению" в 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
Как мне сократить этот код (избавиться от повтора функции)?
Я наверное неправильно написал, мне нужно чтобы для каждого нового поиска слова, надо было не копировать и вставлять заново этот кусок кода:
Код
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
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