Option Explicit

Sub MakeNewSchet()
  Dim wd, wb As Workbook, pt
  pt = GetDataFolder("Выбкерите папку с данными для СЧЕТА")
  If pt = "" Then Exit Sub
'  pt = ThisWorkbook.Path & Application.PathSeparator & "3" ' debug
  Set wd = OpenPDFS(CStr(pt))
  ThisWorkbook.Worksheets(1).Copy: Set wb = ActiveWorkbook
  AddAM wb.Worksheets(1), wd
  AddMsKvo wb.Worksheets(1), wd
  SaveVetS wb, CStr(pt)
  wd.Quit
End Sub



Sub AddAM(ws As Worksheet, wd)
  Dim rg As Range, s$, txt$, am$, p&, re
  txt = wd.Documents(1).Content.Text: s = "Наименование выполненных работ /оказанных услуг"
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = s
  If re.test(txt) Then
    am = re.Execute(txt)(0)
    am = Trim(Replace(Replace(am, "Наименование выполненных работ /оказанных услуг", ""))
    Do While Not Right(am, 1) Like "#"
      am = Left(am, Len(am) - 1)
    Loop
  End If
  If am = "" Then MsgBox "Не найден Наименование выполненных работ /оказанных услуг", vbCritical, _
  "Проблема с файлом Наименование выполненных работ /оказанных услуг": Exit Sub
  s = "Identification /"
  Set rg = ws.Cells.Find(s, , xlValues, xlPart, SearchFormat:=False)
  p = InStr(InStr(rg, vbLf) + 1, rg, vbLf)
  rg = Left(rg, p - 1) & am & Right(rg, Len(rg) - p + 1)
End Sub

Sub SaveVetS(wb As Workbook, pt$)
  Dim ps$, fn$, wb0, fl$
  ps = Application.PathSeparator
  fl = Right(pt, Len(pt) - InStrRev(pt, ps))
  fl = pt & ps & "Контейнер" & fl
  fn = Dir(fl & ".xls*")
  If fn <> "" Then
    Set wb0 = GetObject(pt & ps & fn): wb0.Close False: Kill pt & ps & fn
  End If
  wb.SaveAs fl
  MsgBox "Контейнер сохранен в файле:" & conteiner
End Sub


Function OpenPDFS(pt)
  Dim wd, fn$, r
  pt = pt & Application.PathSeparator
  If Dir(pt & "*Счет №*.pdf") = "" Then LastMsg "Не найден Счет №.pdf!"
  Set OpenPDFS = CreateObject("Word.Application"): OpenPDFS.Visible = True
  fn = Dir(pt & "*Счет №*.pdf"):  OpenPDFS.Documents.Open pt & fn
'  OpenPDFS.ActiveProtectedViewWindow.Edit
  fn = Dir(pt & "*Счет №*.pdf"): OpenPDFS.Documents.Open pt & fn
End Function


Function GetDataFolder$(tit$, Optional Pth$ = "")
  With Application.FileDialog(msoFileDialogFolderPicker)
    If Pth = "" Then Pth = ThisWorkbook.Path
    .ButtonName = "Выбрать": .Title = tit: .InitialFileName = Pth
    If .Show <> -1 Then Exit Function
    GetDataFolder = .SelectedItems(1)
  End With
End Function


Function DelBadDOSChar$(s$)
  Const bch$ = "\/|:+*?<>""%!@."    ' %!@. - не допустимы в некоторых компонентах
  Dim i&:  i = 1
  Do While i <= Len(s)
    If InStr(bch, Mid(s, i, 1)) > 0 Then s = Left(s, i - 1) & Right(s, Len(s) - i) Else i = i + 1
  Loop
  DelBadDOSChar = s
End Function


Sub LastMsg(txt$, Optional tit$ = "Аварийное завершение работы!!!")
  MsgBox txt, vbCritical, tit
  End
End Sub