Получить определенные значения из документа word макросом - VBA
Формулировка задачи:
Здравствуйте!
Подскажите, пожалуйста, можно ли макросом произвести поиск по ключевому слову в документах Word и на основе этого вытащить определенные данные в таблицу Excel или ворд? И как это сделать?
Ситуация:
Есть 4 года и 65 компаний. И есть соответственно 260 отчетов, названных "Компания_год".
В отчетах содержится информация о акционерах компании и их долях.
Во всех отчетах необходимый раздел (да и все разделы) называется одинаково.
Нужно макросом найти этот раздел и вытащить из него пары: "название - доля1, доля2" в отдельный файл.
Название идет после фразы: "Полное фирменное наименование: ", доли после "Доля участия лица в уставном капитале эмитента, %: " и "Доля принадлежащих лицу обыкновенных акций эмитента, %: ".
В идеале должна получится таблица вида (заголовки любые), всего будет 4 листа, каждый для своего года:
Компания1:
Акционер1 доля1 доля2
акционер2 доля1 доля2
акционер3 доля1 доля2
Компания2:
Акционер1 доля1 доля2
акционер2 доля1 доля2
акционер3 доля1 доля2
Прикрепляю файл-пример с разделом отчета, из которого надо вытащить данные
Собственно, вопрос: возможно ли это? и, возможно, кто-то писал подобное и готов поделиться?
Отношения с vba: с языком практически не знакома, но могу читать код и "собирать" из разных макросов, чуть переделывать под себя (но только внутри excel или word). С макросами экспорта из word в excel или наоборот не сталкивалась никогда. Поиск пока выдает только "из excel в word", а не наоборот.
Спасибо!
Решение задачи: «Получить определенные значения из документа word макросом»
textual
Листинг программы
Sub Akzioners() Dim b(), i&, j&, txt$, n&, k&, rw& a = Array("Полное фирменное наименование:", _ "Доля участия лица в уставном капитале эмитента, %:", _ "Доля принадлежащих лицу обыкновенных акций эмитента, %:") Workbooks.Add Set ShExcel = ActiveSheet 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, a(0)) ReDim b(UBound(s), 0 To 2) b(0, 0) = .Name .Close End With s = Split(txt, vbCr) j = 1 For n = 0 To UBound(s) If InStr(1, s(n), a(i)) <> 0 Then b(j, i) = VBA.Trim(Split(s(n), ":")(1)) i = i + 1 If i > 2 Then i = 0: j = j + 1 End If Next With ShExcel rw = IIf(.UsedRange.Rows.Count = 1, 1, .UsedRange.Rows.Count + 1) .Cells(rw, 1).Resize(UBound(b, 1) + 1, UBound(b, 2) + 1) = b End With Next Application.ScreenUpdating = True objWord.Quit End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д