Нужен скрипт сбора информации

[юни]

По мотивам этой темы.

Нужен скрипт, который собирает необходимые данные на разных порталах. Делаем запрос (ОГРН или ИНН), он идёт в поля ввода на сайтах, там получаем страницу с данными, нужные данные агрегируем у себя.

Сайты для парсинга (список может дополниться):

sbis.ru
synapsenet.ru
zachestnyibiznes.ru
list-org.com
spark-interfax.ru
focus.kontur.ru

Кто возьмётся? Сколько стоит?

[lupus_bellus]

Зенка возьмётся. Шаблон не пробовал.

[юни]

Спасибо, глянул. Там вроде только один ресурс парсится. Да и не хочется зенку, надо бы специализированный и компактный самопис.

[burunduk]

Сообщение от юни

Да и не хочется зенку, надо бы специализированный и компактный самопис.

в excel на vba напиши макрос и парси сколько влезет что угодно

вот сам парсер

PHP код:

Function GetHTTPResponse(ByVal sUrl As String) As String
'get запрос
    On Error Resume Next
    Dim oXMLHTTP As Variant
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sUrl, False
         '.SetRequestHeader "Accept", "application/xml"
        .Send
        GetHTTPResponse = .ResponseText
    End With
    Set oXMLHTTP = Nothing
End Function 


вот сохранение если нужно во внешнем файле

PHP код:

Function SaveTextToFile(ByVal txt$, ByVal filename$, Optional ByVal encoding$ = "windows-1251") As Boolean
    ' ôóíêöèÿ ñîõðàíÿåò òåêñò txt â êîäèðîâêå Charset$ â ôàéë filename$
    ' ïðèìåð âûçîâà SaveTextToFile äàííûå, èìÿôàéëà, "utf-8noBOM"
    On Error Resume Next: Err.Clear
    Dim FSO
    Dim ts
    Dim binaryStream
    Select Case encoding$
        Case "windows-1251", "", "ansi"
            Set FSO = CreateObject("scripting.filesystemobject")
            Set ts = FSO.CreateTextFile(filename, True)
            ts.Write txt: ts.Close
            Set ts = Nothing: Set FSO = Nothing
        Case "utf-16", "utf-16LE"
            Set FSO = CreateObject("scripting.filesystemobject")
            Set ts = FSO.CreateTextFile(filename, True, True)
            ts.Write txt: ts.Close
            Set ts = Nothing: Set FSO = Nothing
        Case "utf-8noBOM"
            With CreateObject("ADODB.Stream")
                .Type = 2: .Charset = "utf-8": .Open
                .writetext txt$
                Set binaryStream = CreateObject("ADODB.Stream")
                binaryStream.Type = 1: binaryStream.Mode = 3: binaryStream.Open
                .Position = 3: .CopyTo binaryStream        'Skip BOM bytes
                .flush: .Close
                binaryStream.savetofile filename$, 2
                binaryStream.Close
            End With
        Case Else
            With CreateObject("ADODB.Stream")
                .Type = 2: .Charset = encoding$: .Open
                .writetext txt$
                .savetofile filename$, 2        ' ñîõðàíÿåì ôàéë â çàäàííîé êîäèðîâêå
                .Close
            End With
    End Select
    SaveTextToFile = Err = 0: DoEvents
End Function 


[юни]

Ой... а он с сайтов тоже инфу берёт?

[sony]

Сообщение от юни

Ой... а он с сайтов тоже инфу берёт?

юни, конечно.... VB полюбасу работает именно с http почти с момент рождения...

Админы до сих пор не прикрутили спойлер, поэтому так вставлю (не моё, копипаст)

PHP код:

Sub LoadInfo()
    ' On Error Resume Next
    Dim ra As Range: Set ra = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp))
    If ra.Row = 1 Then MsgBox "На листе не найден список ИНН", vbCritical: Exit Sub
 
    Dim cell As Range, txt$, res$, result_cell As Range, v
 
    Const TIMEOUT& = 6: Static xmlhttp As Object
    If xmlhttp Is Nothing Then Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
 
    For Each cell In ra.Cells
        URL$ = "https://sbis.ru/contragents/" & Trim(cell)
 
        xmlhttp.Open "GET", URL$, True: DoEvents
        xmlhttp.Send: DoEvents
 
        If Not xmlhttp.WaitForResponse(TIMEOUT&) Then
            Debug.Print "timeout", URL
        Else
            txt$ = "": txt$ = xmlhttp.responsetext
            ' обработка ответа сервера
            ' функцию GetTags можно взять здесь: excelvba.ru/code/html
            res$ = "": res$ = GetTags(txt, "div", "class", "cCard__Content-Var", "config 1")
            res$ = Replace(res$, "%22", "'"): res$ = Replace(res$, """", "'")
 
            ' ищем в ответе нужные данные
            With cell.EntireRow
                .Cells(3) = Replace(GetValue(res$, "УставнойКапитал"), " ", "")
                .Cells(4) = GetValue(res$, "Статус")
                .Cells(5) = GetValue(res$, "ВыручкаСтатистика")
                .Cells(6) = GetValue(res$, "ПрибыльСтатистика")
                .Cells(7) = GetValue(res$, "Выручка")
                .Cells(8) = GetValue(res$, "Прибыль")
                .Cells(9) = GetValue(res$, "ЧисленностьСотрудников")
            End With
        End If
    Next cell
End Sub 


или вот (тоже копипаста)

PHP код:

Sub test()
    URL = "https://www.finam.ru/profile/mosbirzha-fyuchersy/1mfr-1-20-mff0_mff0/export/"
    txt = GetHTTPResponse(URL)
 
    txt = Split(txt, "Finam.IssuerProfile.Main.issue")(1)
    txt = Split(txt, """quote"":")(1)
    txt = Split(txt, """id"": ")(1)
    txt = Split(txt, ",")(0)
 
    MsgBox txt ' или Range("a5") = txt
End Sub 


[burunduk]

Сообщение от юни

Ой... а он с сайтов тоже инфу берёт?

откуда угодно, можно даже по апи получать если оно есть

у меня папки с различным парсингом (с тем что схоронилось) уже больше 200Г+
всё с помощью vba выкачивал

[охg]

в excel на vba
расшифруйте чуть, я не прогер

[burunduk]

охg, vba (Visual Basic for Applications) - штатный язык программирования в офисе

excel - просто одна из наиболее удобных платформ пакета офиса, для реализации подобных задач (в принципе тоже самое можно делать в абсолютно любом приложении офиса, хоть в повер поинте), индивидуальных задач связанных с получением и обработкой данных
я приводит тут пример получения и обработки данных по апи от яндекс вебмастера именно в excel

[охg]

я понял... примерно.) вы имете ввиду что на данный момент можно использовать ексел онлайн) блин но я уже использую в продаже мля..
целой кампании помог)
Спасиб за ответ)..
Юни извин за офтоп)..