Sub UPDATE_LAST_10()
Dim LR&, R&, C&, RESP$, URL$
Dim A$(), S$, I&
Dim AA$(), SS$, II&
Dim AAA$(), SSS$, III&
Dim U&
Dim TIR$
Dim V As Range

URL = "http://www.marathontotoservice.com/sttot/Tennis/sttot16.aspx"
RESP = GetHTTPResponse_P(URL)
A = Split(RESP, vbTab & "</tr><tr class=""sttot-row"">")
If UBound(A) <> 10 Then Exit Sub
U = MID_STR(A(10), "id=-", "&")
Set V = Cells.Find(U, Cells(1, 7), , xlWhole)
If V Is Nothing Then
  AP_
  Exit Sub
Else
  R = V.Row
  For I = 10 To 1 Step -1
    U = MID_STR(A(I), "id=-", "&")
    URL = "http:/www.marathontotoservice.com/sttot/Tennis/SttotTime.aspx?id=-" & U & "&GMT=+3"
    RESP = GetHTTPResponse_P(URL)
    AA = Split(RESP, vbTab & "<td class=""tt-cell"">")
    If UBound(A) > 0 Then
      TIR = MID_STR(RESP, "Время начала матчей. Тираж №", vbCrLf)
      For II = 1 To UBound(AA)
'        Cells(R, 1).Select
        SS = AA(II)
        AAA = Split(SS, "<td class=""tt-cell")
        If UBound(AAA) <> 4 Then Stop
        Cells(R, 1) = MID_STR(AAA(0), "", "<")
        Cells(R, 2) = MID_STR(AAA(1), ">", "<")
        Cells(R, 3) = MID_STR(AAA(2), ">", "<")
        Cells(R, 4) = MID_STR(AAA(3), ">", "<")
        Cells(R, 5) = MID_STR(AAA(4), ">", "<")
        Cells(R, 6) = TIR
        Cells(R, 7) = U
        R = R + 1
      Next II
    End If 'UBound(A) > 0 Then
  Next I
End If
End Sub

Private Function GetHTTPResponse_P(ByVal sURL As String) As String
    Dim oXMLHTTP
    On Error Resume Next
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
        GetHTTPResponse_P = .responseText
    End With
    Set oXMLHTTP = Nothing
    If Err Then Stop
End Function

Sub AP_()
Dim LR&, R&, C&, RESP$, URL$
Dim A$(), S$, I&
Dim AA$(), SS$, II&
Dim U&
Dim TIR$
Dim Z&

'R = Cells(Rows.Count, 1).End(xlUp).Row
'If Cells(R, 1) <> "" Then R = R + 1
R = 2
U = 1
Do
  DoEvents
  URL = "http://www.marathontotoservice.com/sttot/Tennis/SttotTime.aspx?id=-" & U & "&GMT=+3"
  RESP = GetHTTPResponse_P(URL)
  A = Split(RESP, vbTab & "<td class=""tt-cell"">")
  If UBound(A) > 0 Then
    Z = 1
    TIR = MID_STR(RESP, "Время начала матчей. Тираж №", vbCrLf)
    For I = 1 To UBound(A)
      'Cells(R, 1).Select
      S = A(I)
      AA = Split(S, "<td class=""tt-cell")
      If UBound(AA) <> 4 Then Stop
      Cells(R, 1) = MID_STR(AA(0), "", "<")
      Cells(R, 2) = MID_STR(AA(1), ">", "<")
      Cells(R, 3) = MID_STR(AA(2), ">", "<")
      Cells(R, 4) = MID_STR(AA(3), ">", "<")
      Cells(R, 5) = MID_STR(AA(4), ">", "<")
      Cells(R, 6) = TIR
      Cells(R, 7) = U
      R = R + 1
    Next I
  Else
    Z = Z + 1
  End If 'UBound(A) > 0 Then
  U = U + 1
Loop While Z < 100
End Sub

Function MID_STR$(S$, S1$, S2$)
Dim P1&, P2&
P1 = InStr(S, S1)

If P1 Then
  If Len(S2) Then
    P2 = InStr(P1 + Len(S1), S, S2)
  Else
    P2 = Len(S) + 1
  End If
  If P2 > P1 Then
    MID_STR = Mid$(S, P1 + Len(S1), P2 - P1 - Len(S1))
  End If

End If

End Function

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