Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA: избавиться от повтора одинаковой функции
 
#1
04.06.2018 11:54:56
Добрый день. У меня есть код, который выполняет поиск слов "по их окружению" в 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
 
 
 
#2
04.06.2018 12:15:24
Если надо обрабатывать сразу много файлов Word, могу посоветовать использовать другой макрос
можете загуглить фразу парсер файлов Word

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

добавить строку
Код
Exit Do
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
04.06.2018 15:00:56
Я наверное неправильно написал, мне нужно чтобы для каждого нового поиска слова, надо было не копировать и вставлять заново этот кусок кода:  
Код
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
Заносились бы туда автоматически.
 
 
 
#4
05.06.2018 04:46:39
Код
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
Читают тему
Наверх