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
Вот изменённый код из вашего файла.
