Function ИзвлечьЧисло(pstrText)

  Set objRegExp = CreateObject("VBScript.RegExp")

  With objRegExp

    .MultiLine = True

    .Global = True

    .Pattern = "\D"

    GetDigitsFromText = .Replace(pstrText, vbNullString)

  End With

  ИзвлечьЧисло = GetDigitsFromText

  Set objRegExp = Nothing

End Function



Sub evsino()

  spath = InputBox("Задай путь к папке", "", "C:\temp")

  If Dir(spath, vbDirectory) = "" Then

    MsgBox "Не правильно указан путь", vbCritical, ""

    End

  End If

  mx = 0

  fn = ""

  Dim fs, f, f1, fc

  Set fs = CreateObject("Scripting.FileSystemObject")

  Set f = fs.GetFolder(spath)

  Set fc = f.Files

  For Each f1 In fc

    nf = ИзвлечьЧисло(f1.Name)

    If mx < nf Then

      mx = nf

      fn = f1.Name

    End If

  Next

  MsgBox "Макимальный файл " & vbCr & fn & vbCr & mx, vbCritical, ""

End Sub

Sub Start()

  If ActiveSheet.Name <> "Лист1" Then

    MsgBox "Запуск макроса не с листа с настройками!", vbCritical, ""

    End

  End If

  file_bl = Cells(2, 2):  file_kn = Cells(3, 2): folder_rez = Cells(4, 2)

  If file_bl = "" Or file_kn = "" Or folder_rez = "" Then

    MsgBox "Не правильно задан путь!", vbCritical, ""

    End

  End If

  If Dir(file_bl) = "" Or Dir(file_kn) = "" Or Dir(folder_rez, vbDirectory) = "" Then

    MsgBox "Не правильно задан путь!", vbCritical, ""

    End

  End If

  If MsgBox("Работаем?", vbQuestion + vbOKOnly, "") = vbCancel Then End

  Application.ScreenUpdating = False

  Application.DisplayAlerts = False

  ' взять номер:

  Workbooks.Open Filename:=file_kn

  ykn = Cells(65536, 1).End(xlUp).Row

  If ykn = 1 Then ykn = ykn + 1

  If IsEmpty(Cells(ykn, 1)) Then Cells(ykn, 1) = 0

  n = Cells(ykn, 1) + 1

  Cells(ykn + 1, 1) = n

  Cells(ykn + 1, 2) = Application.UserName

  Cells(ykn + 1, 3) = Date & " " & Time

  ActiveWorkbook.Save

  ActiveWindow.Close

  ThisWorkbook.Activate

  

  file_zp = folder_rez & Application.PathSeparator & "приказ " & n & ".xls"

  If Dir(file_zp) <> "" Then

    If MsgBox("Файл " & file_zp & vbCr & " уже существут " & vbCr & _

    "ДА - удалить, и продолжить" & vbCr & _

    "Отмена - завершить работу", vbOKCancel + vbQuestion, "") = vbOK Then

      Kill file_zp

    Else

      ' вот здесь надо в книге регистрации удалить последнюю запись...

      End

    End If

  End If

  mes = "Номер " & n

  Workbooks.Open Filename:=file_bl

  ' в открытый бланк вносим данные:

  Cells(2, 2) = n

  ActiveWorkbook.SaveAs Filename:=file_zp

  ActiveWindow.Close

  mes = mes & vbCr & file_zp

  ThisWorkbook.Activate

  MsgBox mes, vbInformation, ""

End Sub