Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA: избавиться от повтора одинаковой функции
 
#1
04.06.2018 11:54:56
Добрый день. У меня есть код, который выполняет поиск слов "по их окружению" в Word файле с помощью макроса в Excel и вставляет их в определенные ячейки. Но код повторяет одну и ту же функцию поиска несколько раз:
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
'''Наименование дисциплины'''
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

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

добавить строку
Код
?
1
Exit Do
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
04.06.2018 15:00:56
Я наверное неправильно написал, мне нужно чтобы для каждого нового поиска слова, надо было не копировать и вставлять заново этот кусок кода:  
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
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
А чтобы поиск был только один, а разные данные для поиска:
Код
?
1
.Text = "дисциплина *относится"

и вставки:
Код
?
1
2
3
4
WordDoc.Range(r.Start + 11, r.End - 9).Copy                
Range("C4").Select
Range("B4").Value = "Название дисциплины"
ActiveSheet.Paste
Заносились бы туда автоматически.
 
 
 
#4
05.06.2018 04:46:39
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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
Читают тему
Наверх
Loading...