1

Тема: Копирование - вставка из Word в Excel нескольких текстов

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

В приложении файл Word - акт ОСР (освидетельствования скрытых работ), в котором красным выделено то, что я по очереди копирую "ручками", а потом вставляю в ячейки реестра формата Excel.

Бесит смена документов для копирования - вставки: Word-копирование, Excel-вставка...
Можно ли как-то сделать, чтобы в Вордовском документе скопировать по очереди все тексты , а потом в реестре автоматом вставить в нужные ячейки?
Важно:
1. шрифт в документе Excel иной, нежели в документе Word, поэтому приходится вставлять не в ячейку, а в строку формул.
2. Даты в реестре - в ином формате, нежели в Ворде, вот такие: 13.06.2017.

Предполагаю, что надо макросом как-то сформировать несколько буферов обмена по количеству копируемых текстов, чтобы потом вставить их содержимое в ячейки Excel.

Прошу помощи. Искал более-менее подходящие макросы, чтобы подстроить "под себя", как здесь, так и на "Планете Excel", но не нашел.

p.s. У меня проблемы не было бы, формируй мы акты ОСР в Excel, но увы, никто из коллег не желает менять уже привычный Word на Excel.

p.p.s Во время работы никакие иные документы, кроме этих двух, не открыты, поэтому в макросе можно не указывать конкретную директорию и название файла.

Post's attachments

Word.docx 21.13 Кб, 5 скачиваний с 2017-06-13 

You don't have the permssions to download the attachments of this post.

2

Re: Копирование - вставка из Word в Excel нескольких текстов

файл эксель тоже нужно бы выложить.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

3

Re: Копирование - вставка из Word в Excel нескольких текстов

Ок, прикладываю.
Там так же выделил красным, что вставляю из Ворда.

Post's attachments

Реестр Excel.xls 24.5 Кб, 3 скачиваний с 2017-06-13 

You don't have the permssions to download the attachments of this post.

4

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

Ок, прикладываю.
Там так же выделил красным, что вставляю из Ворда.

Я так понял там будет много пунктов таких заказов? Предлагаю такой вариант - У вас запросит номер заказа и расставит все данные по ячейкам.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

5

Re: Копирование - вставка из Word в Excel нескольких текстов

Есть множество актов-файлов Word.
Я вручную заношу данные из них в реестр Excel.
В файле Excel я показал только одну первую строчку. Таких строчек много, в соответствии с количеством файлов Word.
И моя голубая мечта: открыть очередной файл Word, выделить и скопировать один красный текст, сразу же выделить и скопировать другой красный текст, далее последовательно повторить выделение и копирование каждого красного текста в этом файле.
Перейти в реестр Excel, активировать первую ячейку нужной строки, нажать "пупочку" и - вуаля! - все скопированные тексты вставлены в соответствующие ячейки строки.
Далее всё повторяется: открываю новый файл Word, произвожу те же телодвижения по выделению и копированию текстов, перехожу в Excel и вставляю скопированное в следующую строчку.
И так до конца.

6

Re: Копирование - вставка из Word в Excel нескольких текстов

Завтра выложу

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

7

Re: Копирование - вставка из Word в Excel нескольких текстов

Благодарю за участие.

8

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

Благодарю за участие.

Вот код для эксель-файла. Чёт увлёкся и не стал откладывать на завтра. Добавляете код в редактор и запускаете макрос "Заполнить строку". Он предложит вам указать номер договора (тут вы вводите число, которое будет стоять в столбце "номер по порядку" для той строки, которую собираетесь заполнять), затем вам будет предложено выбрать документ, из которого брать данные (я указал просто диск С:\, а вы укажите необходимый путь. Это начальный путь, с которого можно будет начинать выбирать файл). Форматирования текста пока что нету.

Sub Заполнить_строку()
Dim sName
Dim iCell As Long
iCell = InputBox("Введите номер договора")
iCell = iCell + 3
Dim oWB As Workbook
Set oWB = ThisWorkbook
RepeatLine:
    sName = My_File_Open
Dim WD As Object
Set WD = CreateObject("Word.Application")
WD.Visible = True
Dim oDoc As Object
Set oDoc = WD.Documents.Open(Filename:=sName)
'sText = oDoc.Tables(2).Cell(1, 1).Range.Text
'Первое значение
sText = oDoc.Tables(2).Cell(1, 1).Range.Text: sText = Left(sText, Len(sText) - 1)
If InStr(sText, "№ ") >= 1 Then sText = Replace(sText, "№ ", "")
sRange = "B" & iCell & ":B" & iCell
oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
    'Второе значение
    sText = oDoc.Tables(2).Cell(1, 2).Range.Text: sText = Left(sText, Len(sText) - 1)
        sMonth = CheckMonth(sText)
    sRange = "I" & iCell & ":I" & iCell
    oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sMonth
        'Третье значение
        sText = oDoc.Tables(2).Cell(24, 2).Range.Text
        sText = Left(sText, Len(sText) - 1)
        If oDoc.Tables(2).Cell(25, 1).Range.Text <> 2 Then
            sTextNext = oDoc.Tables(2).Cell(25, 1).Range.Text
            sTextNext = Left(sTextNext, Len(sTextNext) - 1)
            sTextNext = LTrim(sTextNext)
            sText = RTrim(sText)
            sText = sText & Chr(32) & sTextNext
        End If
        sRange = "E" & iCell & ":E" & iCell
        oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
            '32:2 & 33:1 - Cell J
             sText = oDoc.Tables(2).Cell(32, 2).Range.Text
             sText = Left(sText, Len(sText) - 1)
            If oDoc.Tables(2).Cell(33, 1).Range.Text <> 2 Then
                sTextNext = oDoc.Tables(2).Cell(33, 1).Range.Text
                sTextNext = Left(sTextNext, Len(sTextNext) - 1)
                sTextNext = Trim(sTextNext)
                sText = Trim(sText)
                sText = sText & Chr(32) & sTextNext
            End If
            sRange = "J" & iCell & ":J" & iCell
            oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
                '50:1 - Dates - Cells G & H
                sText = oDoc.Tables(2).Cell(50, 1).Range.Text
                sText = Left(sText, Len(sText) - 1)
                'sStart = StartAndFinish(sText, 1)
                'sFinish = StartAndFinish(sText, 2)
                sStart = Left(sText, InStr(sText, "окончания работ") - 1)
                sStart = Right(sStart, Len(sStart) - InStrRev(sStart, "начала работ ") - 12)
                sStart = Left(sStart, InStr(sStart, "г."))
                sStart = CheckMonth(sStart)
                sFinish = Right(sText, Len(sText) - InStr(sText, "окончания работ ") - 15)
                sFinish = CheckMonth(sFinish)
                sRange = "G" & iCell & ":G" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
                sRange = "H" & iCell & ":H" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
    iRepeat = MsgBox("Добавить ещё данные?", vbYesNo)
    If iRepeat = 6 Then
        WD.Quit
        Set WD = Nothing
        GoTo RepeatLine
    End If
End Sub
Private Function My_File_Open()
Dim oFile
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите нужный файл"
        .ButtonName = "Выбрать файл"
        .InitialFileName = "C:\"
'        .Filters.Add "*.docx", "*.docm", "*.doc", "*.rtf"
        .AllowMultiSelect = False
        .Show
        My_File_Open = .SelectedItems(1)
    End With
End Function
Private Function CheckMonth(ByVal sText As String)
If InStr(sText, "января") >= 1 Then
    sText = Replace(sText, "января", "01.")
ElseIf InStr(sText, "февраля") >= 1 Then
    sText = Replace(sText, "февраля", "02.")
ElseIf InStr(sText, "марта") >= 1 Then
    sText = Replace(sText, "марта", "03.")
ElseIf InStr(sText, "апреля") >= 1 Then
    sText = Replace(sText, "апреля", "04.")
ElseIf InStr(sText, "мая") >= 1 Then
    sText = Replace(sText, "мая", "05.")
ElseIf InStr(sText, "июня") >= 1 Then
    sText = Replace(sText, "июня", "06.")
ElseIf InStr(sText, "июля") >= 1 Then
    sText = Replace(sText, "июля", "07.")
ElseIf InStr(sText, "августа") >= 1 Then
    sText = Replace(sText, "августа", "08.")
ElseIf InStr(sText, "сентября") >= 1 Then
    sText = Replace(sText, "сентября", "09.")
ElseIf InStr(sText, "октября") >= 1 Then
    sText = Replace(sText, "октября", "10.")
ElseIf InStr(sText, "ноября") >= 1 Then
    sText = Replace(sText, "ноября", "11.")
ElseIf InStr(sText, "декабря") >= 1 Then
    sText = Replace(sText, "декабря", "12.")
End If
sText = Replace(sText, Chr(171), "")
sText = Replace(sText, Chr(187), ".")
sText = Replace(sText, "г.", "")
sText = Replace(sText, "г", "")
sText = Replace(sText, Chr(32), "")
CheckMonth = sText
End Function
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

9

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

В ответ на письмо.

Поправил по пунктам, которые вы указали. Теперь не надо перезапускать макрос (не посмотрел, что код выше нужной строки), Документ не закрывался из-за того, что макрос перезапускался - тоже поправил. Настроил автозаполнение Ctrl+D. Нумерация тоже теперь будет.
Единственное условие для правильной работы - надо чтобы таблица 2 не менялась строго до последней ячейки (та, что с датами окончания и начала работ) - т.е. число ячеек должно быть таким же. Советую сделать шаблон , который будет заполняться данными (чтобы таблицы в нём были готовые и их оставалось только заполнить).
По поводу ошибки - без конкретного примера ничего не могу посоветовать.

Замените ваш кода на этот:

Sub Заполнить_строку()
Dim sName
Dim iCell As Long
Dim oWB As Workbook
Set oWB = ThisWorkbook
RepeatLine:
iCell = InputBox("Введите номер договора")
iCell = iCell + 3
                                                                    '<start Автозаполнялка>
                                                                    sRange = "A" & iCell & ":A" & iCell
                                                                    oWB.Worksheets("Лист1 (3)").Range(sRange).Value = iCell - 3
                                                                    sAuto = "C" & iCell
                                                                        Range(sAuto).Select
                                                                        Selection.FillDown
                                                                    sAuto = "D" & iCell
                                                                        Range(sAuto).Select
                                                                        Selection.FillDown
                                                                    sAuto = "F" & iCell
                                                                        Range(sAuto).Select
                                                                        Selection.FillDown
                                                                    '<\end Автозаполнялка>
    sName = My_File_Open
Dim WD As Object
Set WD = CreateObject("Word.Application")
WD.Visible = True
Dim oDoc As Object
Set oDoc = WD.Documents.Open(Filename:=sName)
'sText = oDoc.Tables(2).Cell(1, 1).Range.Text
'Первое значение
sText = oDoc.Tables(2).Cell(1, 1).Range.Text: sText = Left(sText, Len(sText) - 1)
If InStr(sText, "№ ") >= 1 Then sText = Replace(sText, "№ ", "")
sRange = "B" & iCell & ":B" & iCell
oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
    'Второе значение
    sText = oDoc.Tables(2).Cell(1, 2).Range.Text: sText = Left(sText, Len(sText) - 1)
        sMonth = CheckMonth(sText)
    sRange = "I" & iCell & ":I" & iCell
    oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sMonth
        'Третье значение
        sText = oDoc.Tables(2).Cell(24, 2).Range.Text
        sText = Left(sText, Len(sText) - 1)
        If oDoc.Tables(2).Cell(25, 1).Range.Text <> 2 Then
            sTextNext = oDoc.Tables(2).Cell(25, 1).Range.Text
            sTextNext = Left(sTextNext, Len(sTextNext) - 1)
            sTextNext = LTrim(sTextNext)
            sText = RTrim(sText)
            sText = sText & Chr(32) & sTextNext
        End If
        sRange = "E" & iCell & ":E" & iCell
        oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
            '32:2 & 33:1 - Cell J
             sText = oDoc.Tables(2).Cell(32, 2).Range.Text
             sText = Left(sText, Len(sText) - 1)
            If oDoc.Tables(2).Cell(33, 1).Range.Text <> 2 Then
                sTextNext = oDoc.Tables(2).Cell(33, 1).Range.Text
                sTextNext = Left(sTextNext, Len(sTextNext) - 1)
                sTextNext = Trim(sTextNext)
                sText = Trim(sText)
                sText = sText & Chr(32) & sTextNext
            End If
            sRange = "J" & iCell & ":J" & iCell
            oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
                '50:1 - Dates - Cells G & H
                sText = oDoc.Tables(2).Cell(50, 1).Range.Text
                sText = Left(sText, Len(sText) - 1)
                'sStart = StartAndFinish(sText, 1)
                'sFinish = StartAndFinish(sText, 2)
                sStart = Left(sText, InStr(sText, "окончания работ") - 1)
                sStart = Right(sStart, Len(sStart) - InStrRev(sStart, "начала работ ") - 12)
                sStart = Left(sStart, InStr(sStart, "г."))
                sStart = CheckMonth(sStart)
                sFinish = Right(sText, Len(sText) - InStr(sText, "окончания работ ") - 15)
                sFinish = CheckMonth(sFinish)
                sRange = "G" & iCell & ":G" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
                sRange = "H" & iCell & ":H" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
    iRepeat = MsgBox("Добавить ещё данные?", vbYesNo)
    If iRepeat = 6 Then
        WD.Quit
        Set WD = Nothing
        GoTo RepeatLine
    End If
End Sub
Private Function My_File_Open()
Dim oFile
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите нужный файл"
        .ButtonName = "Выбрать файл"
        .InitialFileName = "C:\Users\client606_15\Desktop"
'        .Filters.Add "*.docx", "*.docm", "*.doc", "*.rtf"
        .AllowMultiSelect = False
        .Show
        My_File_Open = .SelectedItems(1)
    End With
End Function
Private Function CheckMonth(ByVal sText As String)
If InStr(sText, "января") >= 1 Then
    sText = Replace(sText, "января", "01.")
ElseIf InStr(sText, "февраля") >= 1 Then
    sText = Replace(sText, "февраля", "02.")
ElseIf InStr(sText, "марта") >= 1 Then
    sText = Replace(sText, "марта", "03.")
ElseIf InStr(sText, "апреля") >= 1 Then
    sText = Replace(sText, "апреля", "04.")
ElseIf InStr(sText, "мая") >= 1 Then
    sText = Replace(sText, "мая", "05.")
ElseIf InStr(sText, "июня") >= 1 Then
    sText = Replace(sText, "июня", "06.")
ElseIf InStr(sText, "июля") >= 1 Then
    sText = Replace(sText, "июля", "07.")
ElseIf InStr(sText, "августа") >= 1 Then
    sText = Replace(sText, "августа", "08.")
ElseIf InStr(sText, "сентября") >= 1 Then
    sText = Replace(sText, "сентября", "09.")
ElseIf InStr(sText, "октября") >= 1 Then
    sText = Replace(sText, "октября", "10.")
ElseIf InStr(sText, "ноября") >= 1 Then
    sText = Replace(sText, "ноября", "11.")
ElseIf InStr(sText, "декабря") >= 1 Then
    sText = Replace(sText, "декабря", "12.")
End If
sText = Replace(sText, Chr(171), "")
sText = Replace(sText, Chr(187), ".")
sText = Replace(sText, "г.", "")
sText = Replace(sText, "г", "")
sText = Replace(sText, Chr(32), "")
CheckMonth = sText
End Function
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

10

Re: Копирование - вставка из Word в Excel нескольких текстов

Раз-раз-раз...
Проверка связи...

11

Re: Копирование - вставка из Word в Excel нескольких текстов

Ура, есть контакт!
(да простит меня Великий Модер за спам 10-поста: не мог ответить на форуме аж трое суток (или четверо? Не помню). Причина - капча шалила: задавала вопрос за вопросом.

Теперь - непосредственно ответ для Fck_This:

Благодарю за макрос. Немного переделал его под себя. Теперь макрос спрашивает номер строки только первый раз, а потом сам переходит на новую строку.
Прошу помочь осуществить ещё пару-тройку моих "хотелок" в приложенном макросе:
1. Хотелось бы, чтобы вместо "Лист1 (3)" использовался открытый в данное время лист с любым названием, то есть ActiveSheet.
2. В функции My_File_Open() директорию
.InitialFileName = "x:\Исполнительная документация по РД\Акты ОСР\"
обыграть так, чтобы я выбрал в диалоговом окне другую директорию, и макрос её запомнил бы на время сессии (пока не закрою файл Excel).
3. Хотелось бы, чтобы макрос, обнаружив ошибку в файле Word, из которого копируются данные, не останавливался бы, открывая окно отладки, а окрашивал бы в сбойной строке Excel неполные данные (какие уж вставились) в красный цвет и продолжал работу, снова запрашивая новый файл, естественно, с переходом на строчку вниз. Ну, а я уж после ввода всех данных вернусь к красным записям и ручками исправлю.
Спасибо.

Post's attachments

Реестр №000+ актов ОСР на 13.06.2017_ШАБЛОН с МАКРОСОМ.xls 47 Кб, 2 скачиваний с 2017-06-17 

You don't have the permssions to download the attachments of this post.

12

Re: Копирование - вставка из Word в Excel нескольких текстов

2)Выбор папки описывается в этом макросе: внешняя ссылка. Добавлять функцию следует перед строкой

RepeatLine:

Что-то вроде:

sFolder = ФункцияПолученияПапки

Строка вызова выбора файла должна выглядеть так

sName = My_File_Open(sFolder)

А функция My_File_Open так:

Private Function My_File_Open(ByVal sFolder as String)
Dim oFile
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите нужный файл"
        .ButtonName = "Выбрать файл"
        .InitialFileName = sFolder
'        .Filters.Add "*.docx", "*.docm", "*.doc", "*.rtf"
        .AllowMultiSelect = False
        .Show
        My_File_Open = .SelectedItems(1)
    End With
End Function

1) Так и укажите в том месте, где вам необходимо чтобы устанавливался активный лист (каждый раз новый или в начале - до строки репитлайн или после)

sSheet = ActiveSheet.Name

И вместо названия листа без кавычек укажите sSheet

3) С ошибкой сложнее. Есть такие варианты:
   а) Просто продолжать действие - добавить в начало программы On Error Resume Next
   б) Запускать обработку ошибки - тогда надо прописывать, что делать в этом случае и возврат в точку отказа (тут вопрос тот же - на какую строку кода обычно ругается [красит в жёлтый]) - On Error GoTo Handler
и прописываем строку
Handler:
Например, If Err.Number = 99 Then
.....

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

13

Re: Копирование - вставка из Word в Excel нескольких текстов

Fck_This, благодарю за помощь.
Метод "On Error Resume Next" меня вполне устроил.
И теперь, когда макрос работает без остановки, я "совершенно обленился" - прошу Вас вписать в макрос функцию

Do While sName <> "" - Loop

в нужные места, чтобы макрос не предлагал мне каждый раз директорию для выбора очередного файла Word", а на автомате обрабатывал вообще все файлы в данной директории.

Спасибо.

14

Re: Копирование - вставка из Word в Excel нескольких текстов

Забыл приложить нужный файл

Post's attachments

Реестр №000++ актов ОСР на 13.06.2017_ШАБЛОН с МАКРОСОМ.xls 47 Кб, 1 скачиваний с 2017-06-19 

You don't have the permssions to download the attachments of this post.

15

Re: Копирование - вставка из Word в Excel нескольких текстов

...а лучше того - обрабатывал бы только все выбранные мультивыбором файлы.

16

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

...а лучше того - обрабатывал бы только все выбранные мультивыбором файлы.

Sub Заполнить_строку()
Dim sName As FileDialogSelectedItems
Dim iCell As Long
Dim oWB As Workbook
On Error Resume Next
Set oWB = ThisWorkbook
iCell = InputBox("Введите номер п/п, с которого начинать заполнение")
If Len(iCell) = 0 Or IsNumeric(iCell) = False Then Exit Sub
iCell = iCell + 2

RepeatLine:
Set sName = My_Files_Open
For Each File In sName
iCell = iCell + 1
Dim WD As Object
Set WD = CreateObject("Word.Application")
WD.Visible = True
Dim oDoc As Object
Set oDoc = WD.Documents.Open(Filename:=File)
'sText = oDoc.Tables(2).Cell(1, 1).Range.Text
'Первое значение
sText = oDoc.Tables(2).Cell(1, 1).Range.Text: sText = Left(sText, Len(sText) - 1)
If InStr(sText, "№ ") >= 1 Then sText = Replace(sText, "№ ", "")
sRange = "B" & iCell & ":B" & iCell
oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
    'Второе значение
    sText = oDoc.Tables(2).Cell(1, 2).Range.Text: sText = Left(sText, Len(sText) - 1)
        sMonth = CheckMonth(sText)
    sRange = "I" & iCell & ":I" & iCell
    oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sMonth
        'Третье значение
        sText = oDoc.Tables(2).Cell(24, 2).Range.Text
        sText = Left(sText, Len(sText) - 1)
        If oDoc.Tables(2).Cell(25, 1).Range.Text <> 2 Then
            sTextNext = oDoc.Tables(2).Cell(25, 1).Range.Text
            sTextNext = Left(sTextNext, Len(sTextNext) - 1)
            sTextNext = LTrim(sTextNext)
            sText = RTrim(sText)
            sText = sText & Chr(32) & sTextNext
        End If
        sRange = "E" & iCell & ":E" & iCell
        oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
            '32:2 & 33:1 - Cell J
             sText = oDoc.Tables(2).Cell(32, 2).Range.Text
             sText = Left(sText, Len(sText) - 1)
            If oDoc.Tables(2).Cell(33, 1).Range.Text <> 2 Then
                sTextNext = oDoc.Tables(2).Cell(33, 1).Range.Text
                sTextNext = Left(sTextNext, Len(sTextNext) - 1)
                sTextNext = Trim(sTextNext)
                sText = Trim(sText)
                sText = sText & Chr(32) & sTextNext
            End If
            sRange = "J" & iCell & ":J" & iCell
            oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sText
                '50:1 - Dates - Cells G & H
                sText = oDoc.Tables(2).Cell(50, 1).Range.Text
                sText = Left(sText, Len(sText) - 1)
                'sStart = StartAndFinish(sText, 1)
                'sFinish = StartAndFinish(sText, 2)
                sStart = Left(sText, InStr(sText, "окончания работ") - 1)
                sStart = Right(sStart, Len(sStart) - InStrRev(sStart, "начала работ ") - 12)
                sStart = Left(sStart, InStr(sStart, "г."))
                sStart = CheckMonth(sStart)
                sFinish = Right(sText, Len(sText) - InStr(sText, "окончания работ ") - 15)
                sFinish = CheckMonth(sFinish)
                sRange = "G" & iCell & ":G" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
                sRange = "H" & iCell & ":H" & iCell
                oWB.Worksheets("Лист1 (3)").Range(sRange).Value = sStart
WD.Quit
Set WD = Nothing
Next File
    iRepeat = MsgBox("Добавить ещё данные?", vbYesNo)
    If iRepeat = 6 Then
        GoTo RepeatLine
    End If
    iCell = 0
End Sub
Private Function My_Files_Open() As FileDialogSelectedItems
Dim oFile
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите нужный файлы"
        .ButtonName = "Выбрать файлы"
         .InitialFileName = "C:\Users\client606_15\Desktop\Новая папка"
'        .InitialFileName = "x:\Исполнительная документация по РД\Акты ОСР\"

'        .Filters.Add "*.docx", "*.docm", "*.doc", "*.rtf"
        .AllowMultiSelect = True
        .Show
        Set My_Files_Open = .SelectedItems
    End With
End Function
Private Function CheckMonth(ByVal sText As String)
If InStr(sText, "января") >= 1 Then
    sText = Replace(sText, "января", "01.")
ElseIf InStr(sText, "февраля") >= 1 Then
    sText = Replace(sText, "февраля", "02.")
ElseIf InStr(sText, "марта") >= 1 Then
    sText = Replace(sText, "марта", "03.")
ElseIf InStr(sText, "апреля") >= 1 Then
    sText = Replace(sText, "апреля", "04.")
ElseIf InStr(sText, "мая") >= 1 Then
    sText = Replace(sText, "мая", "05.")
ElseIf InStr(sText, "июня") >= 1 Then
    sText = Replace(sText, "июня", "06.")
ElseIf InStr(sText, "июля") >= 1 Then
    sText = Replace(sText, "июля", "07.")
ElseIf InStr(sText, "августа") >= 1 Then
    sText = Replace(sText, "августа", "08.")
ElseIf InStr(sText, "сентября") >= 1 Then
    sText = Replace(sText, "сентября", "09.")
ElseIf InStr(sText, "октября") >= 1 Then
    sText = Replace(sText, "октября", "10.")
ElseIf InStr(sText, "ноября") >= 1 Then
    sText = Replace(sText, "ноября", "11.")
ElseIf InStr(sText, "декабря") >= 1 Then
    sText = Replace(sText, "декабря", "12.")
End If
sText = Replace(sText, Chr(171), "")
sText = Replace(sText, Chr(187), ".")
sText = Replace(sText, "г.", "")
sText = Replace(sText, "г", "")
sText = Replace(sText, Chr(32), "")
CheckMonth = sText
End Function

Вот изменённый код из вашего файла.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

17

Re: Копирование - вставка из Word в Excel нескольких текстов

Вводить, по-прежнему, номер по порядку из таблицы. В таком варианте код заполняет выбранную строку и следующие за ней т.е. + 1

Мультиселекс есть - выбор файлов через Ctrl (по одному) или через Shift (областью от-до)

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

18

Re: Копирование - вставка из Word в Excel нескольких текстов

Да, я только вместе "С:\Новая папка" поставил свой путь

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

19

Re: Копирование - вставка из Word в Excel нескольких текстов

Прекрасно! Работает.
Кое-что подправил (в строке даты окончания, там, где вставка в столбец "H", исправил sStart на sFinish).
Наверное, последняя просьба:
как бы сделать, чтобы после выбора иной, новой  директории, она запоминалась бы. И при следующем запуске макроса уже открывалась бы новая директория для выбора файлов Word.
Спасибо.
p.s. Почему при копировании-вставке макроса в модуль весь русский шрифт превращается в набор вопросов, вот так: "??????? ???  ??????". Приходится вручную перебивать. Как это исправить? Где-то должна быть настройка.

Post's attachments

Реестр №000+ актов ОСР_ШАБЛОН с МАКРОСОМ.xls 48 Кб, 1 скачиваний с 2017-06-20 

You don't have the permssions to download the attachments of this post.

20

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

p.s. Почему при копировании-вставке макроса в модуль весь русский шрифт превращается в набор вопросов, вот так: "??????? ???  ??????". Приходится вручную перебивать. Как это исправить? Где-то должна быть настройка.

Про шрифт: когда вы копируете текст на английской раскладке - кириллица превращается в вопросы. Т.е. Переключите на русский язык, а затем скопируйте текст. На каком языке производить вставку - не важно.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

21

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

Наверное, последняя просьба:
как бы сделать, чтобы после выбора иной, новой  директории, она запоминалась бы. И при следующем запуске макроса уже открывалась бы новая директория для выбора файлов Word.
Есть такая штука - "Дополнительные свойства" документа. Создаём новое свойство с конкретным именем, например "sInitialPath" (Для этого жмём "Файл" -> справа вверху "Свойства" -> "Дополнительные свойста" -> вкладка "Прочіе" Тут создаём новое свойство типа Текст.
Обращаться к этому свойству в текущем макросе можно будет так
oWB.CustomDocumentProperties("sInitialPath").Value (то что в строке. Пустым оно быть не может, поэтому советую создавать его с неразрывным пробелом Shift + Ctrl + пробел - потом можно будет узнать пустое ли оно т.е. = Chr(160) или нет)
+ добавляем функцию
Private Function My_Folder_Path() As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .ButtonName = "Выбрать папку": .InitialFileName = "C:\"
    .Show
    My_Folder_Path = .SelectedItems(1)
End With
End Function

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

22

Re: Копирование - вставка из Word в Excel нескольких текстов

Создал новое свойство, добавил функцию. Не работает. Что-то не так сделал sad
А вот я нашел в инете такое:
_____________________________________________________
Ещё один вариант кода (который я использую) для выбора файла
Его отличие - функция запоминает папку, из которой последний раз выбирался файл,
и при повторном запуске диалогового окна выбора файла,
обзор папок будет начат с той папки, откуда последний раз был взят файл.

Sub AttachFile_test()    ' пример использования
    Filename$ = GetFilePath()
    If Filename$ = "" Then Exit Sub
    MsgBox "Выбран файл: " & Filename$
End Sub
 
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Файлы счетов", _
                     Optional ByVal FilterExtention As String = "*.*") As String
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title:
        .InitialFileName = GetSetting(Application.Name, "GetFilePath", "folder", InitialPath)
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1)
        folder$ = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
        SaveSetting Application.Name, "GetFilePath", "folder", folder$
    End With
End Function

(Взято отсюда: внешняя ссылка )
__________________________________________________
Не могли бы Вы изменить переменные на нужные, применительно к моему файлу, чтобы оно работало?
Спасибо.

Post's attachments

Реестр №000+ актов ОСР_ШАБЛОН с МАКРОСОМ.xls 51 Кб, файл не был скачан. 

You don't have the permssions to download the attachments of this post.

23

Re: Копирование - вставка из Word в Excel нескольких текстов

Данный макрос хорошо работает только если все документы Word выполнены по одному типу. Чуть одна лишняя строчка в очередном документе - и всё идёт насмарку, этот документ вводится не верно.

Вопрос: а как в документе Word запретить изменение формата таблиц: добавление/удаление/объединение/разбиение строк, ячеек? Чтобы сами таблицы в документе были для пользователя "железобетонные", но пользователь мог набирать в их ячейках любой текст.

24

Re: Копирование - вставка из Word в Excel нескольких текстов

В продолжение идеи "железобетонных" таблиц:
скорее всего, мне не удастся все формы актов привести к единому формату - акты на:
- разбивку осей
- котлованы
- песчаные подсыпки
- подбетонки
- опалубки.....
И каждый акт требует своего количества тех или иных строчек для заполнения.
Самые сбойные - это ячейки дат начала и окончания работ, потому что выше этих строк количество других строчек в разных актах различное.
Как бы сделать, чтобы макрос находил нужную ячейку по признаку содержания текста:
"1. К освидетельствованию";
"2. Работы выполнены";
"5. Даты:".

25

Re: Копирование - вставка из Word в Excel нескольких текстов

MrBrown пишет:

В продолжение идеи "железобетонных" таблиц:
скорее всего, мне не удастся все формы актов привести к единому формату - акты на:
- разбивку осей
- котлованы
- песчаные подсыпки
- подбетонки
- опалубки.....
И каждый акт требует своего количества тех или иных строчек для заполнения.
Самые сбойные - это ячейки дат начала и окончания работ, потому что выше этих строк количество других строчек в разных актах различное.
Как бы сделать, чтобы макрос находил нужную ячейку по признаку содержания текста:
"1. К освидетельствованию";
"2. Работы выполнены";
"5. Даты:".

Можно и так сделать - проверять содержимое каждой ячейки таблицы на содержание текста-маркера. Тогда не будет привязки к конкретной ячейке. Я бы остановился на этом варианте, если не хочется заморачиваться, хотя в идеале сделать шаблон формата .dot на все виды работ. Т.е. - перед запуском файла у вас спросят "Какой вид работы" и предложит варианты: 1..., 2..., 3... и т.д.  На основе выбора будет создан файл Word с определённым числом ячеек, в котором было бы разрешено редактировать только определённые области - для ввода данных. Тогда было бы единообразие всех документов.
Или можно сделать текстовые поля ввода, которые необходимо будет заполнить, а всё остальное будет запрещено редактировать. (Вот здесь есть примеры разных видов защиты документа внешняя ссылка

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

26

Re: Копирование - вставка из Word в Excel нескольких текстов

Вот файл, в котором работает запоминание папки. Та функция выбора папки - не запоминает папку при завершении работы программы. В данном файле будет работать запоминание начальной папки даже после завершения работы Эксель. Если вам не нужно будет использовать функцию автозаполнения остальных ячеек таблицы - просто закомментируйте строку

Call Fill_Like_Other(iCell, oWB)
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

27

Re: Копирование - вставка из Word в Excel нескольких текстов

Забыл файл прикрепить.

Post's attachments

Реестр №000++ актов ОСР на 13.06.2017_ШАБЛОН с МАКРОСОМ.xls 54.5 Кб, 2 скачиваний с 2017-06-22 

You don't have the permssions to download the attachments of this post.
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

28

Re: Копирование - вставка из Word в Excel нескольких текстов

О ещё 1 вариант вспомнил для блокировки. Можно сделать полями необходимые элементы, а заполняется пусть документ из формы с последующим внесением в соответствующие свойства - куда вводим наименования, даты и проч.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

29

Re: Копирование - вставка из Word в Excel нескольких текстов

Увы, варианты с формами .dot, полями и пр. - не подойдут, так как нередко приходится пользоваться сторонними актами Word, очень похожими и, в то же время, "кривыми" в отношении  нашего макроса.
Но во всех актах тексты, выполненные жирным шрифтом - одинаковые, стандартные, поэтому и надо от них отталкиваться.

Вот, думаю, точнее, прошу, организовать кодом часть макроса с таким алгоритмом:
1. Поиск (Find) ячейки, содержащей часть текста "...к освидетельствованию предъявлены..."
2. Переход на следующую ячейку правее (offset)
3. Выуживание текста из этой ячейки
4. копирование текста
5. вставка текста в соответствующую ячейку реестра Excel
6. продолжение сканирования последующих ячеек/строчек вниз по документу до ячейки, содержащей текст "...работы выполнены...", исключая строки с высотой шрифта менее 12 или с текстом "наименование скрытых работ".
7. последовательная вставка, точнее, добавление, найденных текстов в ту же ячейку реестра Excel.

Очень хочется разобраться в коде такого алгоритма. Поэтому прошу закомментировать строчки кода.
Спасибо.