Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.80/5: Рейтинг темы: голосов - 5, средняя оценка - 4.80
Dmit86
0 / 0 / 0
Регистрация: 30.01.2017
Сообщений: 5
1

Получить значения из документа word по маске макросом в excel

01.02.2017, 15:10. Просмотров 943. Ответов 6
Метки нет (Все метки)

Здравствуйте!

Подскажите, пожалуйста, можно ли макросом произвести поиск по маске в документах Word и вывести все значения в таблицу Excel? И как это сделать?

Ситуация:
есть около 300 документов word нужно достать значения, находящиеся в фигурных скобках Пример {Part1.1.8 REQ 2.8.1.f1.3.2-000-X, 2.8.1.1.2.7-000-Z}
Т.е. маска поиска в word подстановочными знаками [{]?*[}]

В экселе нужно получить:
имя файла | Part1.1.8 REQ 2.8.1.f1.3.2-000-X, 2.8.1.1.2.7-000-Z (все значения в скобках по документу через запятую и пробел)

Уважаемый toiai в теме Получить определенные значения из документа word макросом помогал участнику форума с аналогичной задачей, однако, у меня не получается адаптировать этот макрос под мою задачу.
0
Вложения
Тип файла: docx example.docx (19.0 Кб, 3 просмотров)
Тип файла: docx example2.docx (19.3 Кб, 2 просмотров)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
01.02.2017, 15:10
Ответы с готовыми решениями:

Получить определенные значения из документа word макросом
Здравствуйте! Подскажите, пожалуйста, можно ли макросом произвести поиск по...

Открытие документа Word с форматированием - макросом из Excel
Народ такой вопрос есть макрос под EXCEL открывающий word документ, копирует...

Макросом в Excel получить данные из Word файлов
Добрый день, стоит задача макросом в Excel получить данные из Wordовских...

Копирование содержимого word в word из Excel с макросом
Ребят, добрый вечер! Подскажите,. пожалуйста, мне надо по сути создать копию...

Удалить весь текст/данные из Word документа VBA макросом
Добрый день уважаемые господа. Столкнулся с некой задачей удаления данных из ms...

6
toiai
3094 / 887 / 193
Регистрация: 29.05.2010
Сообщений: 1,906
01.02.2017, 15:18 2
Цитата Сообщение от Dmit86 Посмотреть сообщение
ерез запятую и пробел
Может быть в отдельную ячейку (вдруг длинна строки превысит допустимое).
0
Dmit86
0 / 0 / 0
Регистрация: 30.01.2017
Сообщений: 5
01.02.2017, 15:30  [ТС] 3
toiai, отдельной строкой тогда будет удобнее, пускай имя файла повторяется
имя файла1 | Part1.1.8 REQ 2.8.1.f1.3.2-000-X, 2.8.1.1.2.7-000-Z
имя файла1 | фывафвart1.1.8 RаваEQ 2.8.1.f1.3.2вава-000-X, 2.8вава.1.1.2.7-000-Z
имя файла2 | 1.1.2.7-000-Zтт
имя файла2 | REQ 0705546
0
toiai
3094 / 887 / 193
Регистрация: 29.05.2010
Сообщений: 1,906
01.02.2017, 16:56 4
Лучший ответ Сообщение было отмечено Dmit86 как решение

Решение

Запуск из Excel:
Visual Basic
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
Sub InfaScobok()
    Dim b(), i&, j&, txt$, n&, k&, rw&
    Workbooks.Add
    Set ShExcel = ActiveSheet
    Cells(1, 1) = "Имя файла"
    FileDocs = Application.GetOpenFilename(filefilter:="Documents(*.doc;*.docx),*.doc;*.docx", _
                Title:="Выберите файлы с данными", MultiSelect:=True)
    If Not IsArray(FileDocs) Then Exit Sub
    Application.ScreenUpdating = False
    Set objWord = CreateObject("Word.Application")
    'objWord.Visible = True
    For k = 1 To UBound(FileDocs)
        With objWord.Documents.Open(FileDocs(k))
            txt = .Range.Text
            s = Split(txt, "{")
            ReDim b(1 To UBound(s))
            NameFile = .Name
            .Close
        End With
        j = 1
        For n = 1 To UBound(s)
            b(n) = Split(s(n), "}")(0)
        Next
        With ShExcel
            rw = .UsedRange.Rows.Count + 1
            .Cells(rw, 1).Resize(UBound(b), 1) = NameFile
            .Cells(rw, 2).Resize(UBound(b), 1) = Application.Transpose(b)
        End With
    Next
    Application.ScreenUpdating = True
    objWord.Quit
End Sub
1
Dmit86
0 / 0 / 0
Регистрация: 30.01.2017
Сообщений: 5
02.02.2017, 12:03  [ТС] 5
toiai, сто тысяч благодарностей! Именно то, что нужно!

Добавлено через 18 часов 58 минут
toiai, работает хорошо, но столкнулся с 2мя проблемами:
1. Увы, но бывают значения более 256 символов в скобках
2. Если попадаются файлы без таких скобочек, макрос вылетает
0
toiai
3094 / 887 / 193
Регистрация: 29.05.2010
Сообщений: 1,906
02.02.2017, 21:44 6
Лучший ответ Сообщение было отмечено Dmit86 как решение

Решение

Dmit86, чуть позже подкорректирую код.

Добавлено через 6 часов 34 минуты
Цитата Сообщение от Dmit86 Посмотреть сообщение
1. Увы, но бывают значения более 256 символов в скобках
Подкорректировал код -теперь запись в несколько колонок одной строки.
Пробуй:
Кликните здесь для просмотра всего текста
Visual Basic
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
Sub InfaScobok()
    Dim b(), i&, j&, txt$, n&, k&, rw&, NameFile$, col&
    Workbooks.Add
    Set ShExcel = ActiveSheet
    Cells(1, 1) = "Имя файла"
    FileDocs = Application.GetOpenFilename(filefilter:="Documents(*.doc;*.docx),*.doc;*.docx", _
                Title:="Выберите файлы с данными", MultiSelect:=True)
    If Not IsArray(FileDocs) Then Exit Sub
    Application.ScreenUpdating = False
    Set objWord = CreateObject("Word.Application")
    'objWord.Visible = True
    For k = 1 To UBound(FileDocs)
        With objWord.Documents.Open(FileDocs(k))
            txt = .Range.Text
            s = Split(txt, "{")
            NameFile = .Name
            .Close
            If UBound(s) = 0 Then GoTo Sled
            ReDim b(1 To UBound(s), 1 To 1)
        End With
        For n = 1 To UBound(s)
            txt = Split(s(n), "}")(0)
            col = Len(txt) \ 256 + 1
            If col > UBound(b, 2) Then ReDim Preserve b(1 To UBound(b, 1), 1 To col)
            For i = 1 To col
                b(n, i) = Mid(txt, (i - 1) * 256 + 1, 256)
            Next
        Next
        With ShExcel
            rw = .UsedRange.Rows.Count + 1
            .Cells(rw, 1).Resize(UBound(b), 1) = NameFile
            .Cells(rw, 2).Resize(UBound(b), UBound(b, 2)) = b
        End With
Sled:
    Next
    Application.ScreenUpdating = True
    objWord.Quit
End Sub
1
Dmit86
0 / 0 / 0
Регистрация: 30.01.2017
Сообщений: 5
03.02.2017, 11:53  [ТС] 7
toiai, Теперь отрабатывает просто великолепно!
Еще раз низкий поклон!
0
03.02.2017, 11:53
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
03.02.2017, 11:53

Запуск макроса excel макросом из word
Помогите, пожалуйста. Необходимо запустить макрос в excel при помощи макроса в...

Замена текста в Word макросом из Excel
Есть файл Экселя с данными, есть текстовый шаблон Ворда с метками для этих...

Перевод курсора в Word на следующую строку, макросом из Excel
Добрый день. Имеется таблица в Ворде, макрос работает из Экселя. На закладку...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
7
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru