Sub Parser()
 
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set objRegExp = CreateObject("VBScript.RegExp")
     
    URL = "https://www.sima-land.ru/4794023/nabor-dlya-sortirovki-sorter-bomboshki/"
    URL_autorization = "https://www.sima-land.ru/api/v3/login-form/"
    entity = "******"
    Password = "******"
    g_recaptcha_response = " "
    PostData = "g_recaptcha_response: " & ", entity: " & entity & ", password: " & Password

    'Подсмотрел в Request Payload но не могу написать запрос, что бы авторизоваться
    '"{"g_recaptcha_response": "", "entity": "******", "password": "******"}"

    With oHttp
       .Open "post", URL_autorization, False
       .Send PostData
    End With
    
    'После авторизации переходим на страницу с товаром и копируем код страницы в переменную
    
    oHttp.Open "GET", URL, False
    oHttp.Send
    htmlcode = oHttp.ResponseText
    Set oHttp = Nothing
    
    'Ищем на странице информацию об остатке товара, если авторизация прошла, то будет количество,
    'если нет то будет надпись "На складе достаточно"

    ссылкаНачало = InStr(1, htmlcode, "На складе")
    ссылкаКонец = InStr(ссылкаНачало, htmlcode, "<")
    outstr = Mid(htmlcode, ссылкаНачало, ссылкаКонец - ссылкаНачало)
    Cells(1, 1) = outstr
 
End Sub

Sub Макрос3()

On Error Resume Next
ActiveSheet.ShowAllData
    Range("A7:H23").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Range("A1:H4"), Unique:=False
End Sub

Sub Zapros()
    Dim sURI As String
    Dim oHttp As Object
    Dim htmlcode, outstr As String
    Dim inpdate As Date
    Dim d, m, y As Integer
    sURI = "http://www.toys.ost-com.ru/?task=noFilter&groupId=74171"
        On Error Resume Next
        Set oHttp = CreateObject("MSXML2.XMLHTTP")
        If Err.Number <> 0 Then
            Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
        End If
        On Error GoTo 0
        If oHttp Is Nothing Then
            Exit Sub
        End If
        oHttp.Open "GET", sURI, False
        oHttp.Send
        htmlcode = oHttp.responseText
        Set oHttp = Nothing
    'Debug.Print htmlcode
C = 1
catx = 1
cat = InStr(catx, htmlcode, "class=" & """" & "article" & """") + 18
'Поиск Артикула
Do While cat > 0
cat = InStr(catx, htmlcode, "class=" & """" & "article" & """") + 18
If cat < catx Then
MsgBox "OK"
Exit Sub
End If
cat = InStr(catx, htmlcode, "class=" & """" & "article" & """") + 18
cat1 = InStr(cat, htmlcode, "<")
art = Mid(htmlcode, cat, cat1 - cat)
'Debug.Print art

Cells(C, 3) = art
C = C + 1
catx = cat
Loop

End Sub

Sub УбратьЗнаки2()

Text = "B123456-R2"
Text = Replace(Text, "-R*", "")
        
MsgBox (Text)
End Sub