Доброго времени, форумчане. Помогите с макросом. Запускается из Exel. Есть файл Ворд. Есть текст, который всегда находится между словами "Приложения:" и "Представитель". Необходимо скопировать данный текст в ThisWorkbook. Написал часть кода. Не могу найти инфу, как определить данный кусок текста.
Код
Sub Find_Copy_Paste()
Dim myWord As Object, myDoc As Object, myText As Object
Dim lastRow As Long
Dim Name As String
Dim strText1 As String, strText2 As String
Dim strN As String, strK As String 'переменные начала и конца копируемого текста
Name = ThisWorkbook.Worksheets("ID+cert").Range("B2") & ".docx"
strText1 = "Приложения:" '+1 - Начало фрагмента текста
strText2 = "Представитель" '-1 - Конец фрагмента текста
Set myWord = GetObject(, "Word.Application")
Set myDoc = myWord.Documents(Name)
Set myText = myDoc.Range
ThisWorkbook.Worksheets("Листы").Range("A3") = скопированный текст
End Sub
Возможно кто-то сталкивался с подобным? На форуме находил похожие темы, но там описывают работу из-под файла ворд.
написал: Понятно, что на форуме по Excel, глупо задавать вопрос по кройке/шитью. Ознакомьтесь с Правилами и предложите название для Темы. Помощи скрыта
Добрый день. Подскажите как изменить тему. Я не смог найти решение (
Добрый день. Подскажите пожалуйста, где собака зарыта? Есть книга с несколькими листами. Создал форму и написал макрос. Все работает, но правильные данные макрос вытягивает, только если находишься на листе который указал в форме. А хочется что бы правильные данные вытягивались при нахождении в любом месте книги.
andypetr, огромное спасибо. Ваш код работает. Разрешите еще один совет: код заполняет вот такую таблицу (первые 6 колонок).
Как можно заполнить столбец G (Номер акта) значениями из переменной NumAct (колонку на скрине я заполнил в ручную)? Я уже вам благодарен за подсказку, но если Вас не затруднит, посмотрите код еще раз пожалуйста.
Добрый день, форумчане. Возникла ошибка 429 в коде. Смысл кода - найти файл ворд на сервере (все пути на отдельном листе Акты) и скопировать данные из таблиц в эксель. Без цикла For Line... код работает идеально, но требуется обработать более 3000 строк. И вот я решил попробовать цикл. Желтым горит строчка Set objWrdApp = GetObject(, "Word.Application"). Возможно подскажите в чем кроется проблема. Я сам начинающий пользователь VBA, поэтому прошу не ругаться если код не идеальный ) Сам код ниже.
Код
Sub Copy_Paste_Full()
Dim lastRow As Long
Dim Line As Long
Dim NumAct As String, Path As String
Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim lCol As Long, aTbl As Long, i As Long, j As Long, lastRow_1 As Long
lastRow = ThisWorkbook.Worksheets("Акты").Range("A" & Rows.Count).End(xlUp).Row
For Line = 2 To lastRow
NumAct = ThisWorkbook.Worksheets("Акты").Range("A" & Line)
Path = ThisWorkbook.Worksheets("Акты").Range("B" & Line)
' On Error Resume Next
Set objWrdApp = GetObject(, "Word.Application")
If objWrdApp Is Nothing Then
Set objWrdApp = CreateObject("Word.Application")
Set objWrdDoc = objWrdApp.Documents.Open(Path)
objWrdDoc.Activate
objWrdApp.Visible = True
End If
lCol = objWrdDoc.tables.Count
For aTbl = 2 To lCol - 1
ReDim arr(1 To objWrdDoc.tables(aTbl).Rows.Count, 1 To objWrdDoc.tables(aTbl).Columns.Count)
For j = 1 To UBound(arr, 2)
For i = 2 To UBound(arr, 1)
arr(i, j) = Trim(Replace(objWrdDoc.tables(aTbl).cell(i, j).Range.Text, Chr(7), ""))
Next i
Next j
lastRow_1 = ThisWorkbook.Worksheets("ID").Range("A" & Rows.Count).End(xlUp).Row
ThisWorkbook.Sheets("ID").Range("A" & lastRow_1 + 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
If Range("A" & lastRow_1 + 1) = "" Then
Range("A" & lastRow_1 + 1).EntireRow.Delete
End If
Next aTbl
GetObject(, "Word.Application").Quit
Next Line
End Sub
Уважаемые, подскажите пожалуйста, а можно ли разбить сразу несколько столбцов на строки (по разделителю "перенос") каким-либо способом, т.к. стандартным подходом PQ не позволяет. Количество разделений в ячейках совпадает. В файле пример (возможно самый грубый). Возможно макрос есть какой.
Я еще тот кодер - посмотрел и ... В общем, все печально для меня. Я только начинаю познавать дзен VBA. Я весь код собирал по крохам из инета ) Возможно подскажите, где можно подсмотреть подобный код?
Доброго дня форумчане. Прошу помощи у знающих. Есть код: он открывает файл ворд по указанному адресу и выкопирует таблицы
Код
Sub Copy_Paste()
Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim NameFile As String, NameFolder As String
Dim lCol As Long, aTbl As Long, i As Long, j As Long, lastRow3 As Long
NameFolder = Range("B1").Value & "\"
NameFile = NameFolder & Range("B2") & ".docx"
On Error Resume Next
Set objWrdApp = GetObject(, "Word.Application")
If objWrdApp Is Nothing Then
Set objWrdApp = CreateObject("Word.Application")
Set objWrdDoc = objWrdApp.Documents.Open("\\x-srv63-x\xxxx\xxxx\xxxx\1\xxxx\" & NameFile)
objWrdDoc.Activate
objWrdApp.Visible = True
End If
'lCol = objWrdDoc.tables.Count
'
'For aTbl = 2 To lCol - 1
' ReDim arr(1 To objWrdDoc.tables(aTbl).Rows.Count, 1 To objWrdDoc.tables(aTbl).Columns.Count)
' For j = 1 To UBound(arr, 2)
' For i = 2 To UBound(arr, 1)
' arr(i, j) = Trim(Replace(objWrdDoc.tables(aTbl).cell(i, j).Range.Text, Chr(7), ""))
' Next i
' Next j
'
' With Sheets("ID")
' lastRow3 = ThisWorkbook.Worksheets("ID").Range("A" & Rows.Count).End(xlUp).Row
' End With
'
' ThisWorkbook.Sheets("ID").Range("A" & lastRow3 + 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
'
' If Range("A" & lastRow3 + 1) = "" Then
' Range("A" & lastRow3 + 1).EntireRow.Delete
' End If
'
'Next
End Sub
Проблема вот с этой строкой
Set objWrdDoc = objWrdApp.Documents.Open("\\xxx-srv63-xx\xxxx\xxxx\xxxx\1\xxxx\" & NameFile)
При открытии с рабочего стола/диска С: файл код работает. Но если путь указывает на сервер (как в приложении) - открывается пустой файл ворд. Подскажите, пжл, в чем может быть проблема? Заранее благодарю за помощь.
Доброго времени. Прошу дать подсказку какие функции необходимо использовать для выполнения задачи. Условие в приложенном файле. Через ИНДЕКС ПОИСКПОЗ могу найти значение ячейки. Но как суммировать я голову сломал.