Поиск по сайту в Excel

Question

У меня есть таблица в Excel со списком названий продуктов. Что я хочу сделать, это (1) разделить каждое из этих названий продуктов на 5 строк и (2) настроить поиск по сайту, который извлекает данные с данного сайта (clintrials.gov) и заполняет их в строках под каждой электронной таблицей.

(2) для меня сейчас гораздо важнее и сложнее. Я знаю, что должен запустить цикл, который проходит через все названия продуктов. Но прежде чем я сосредоточусь на цикле, мне нужно помочь разобраться, как написать код, который выполняет поиск по сайту.

Некоторая помощь, которую я получил:

Следующий фрагмент кода Excel VBA примет ячейку с созданным URL-адресом в виде:

="URL;http://clinicaltrials.gov/ct2/show?term="& [Cell Reference to Drug name here] &"&rank=1"

И вывести 4 строки, такие как:

Estimated Enrollment:   40
Study Start Date:   Jan-11
Estimated Study Completion Date:    Apr-12
Estimated Primary Completion Date:  April 2012 (Final data collection date for primary outcome measure)

---

    With ActiveSheet.QueryTables.Add(Connection:= _
            ActiveCell.Text, Destination:=Cells(ActiveCell.Row, ActiveCell.Column + 1))
            .Name = "Clinical Trials"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "12"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    

Answer 1

Указанный вами URL не будет работать. Вам нужен идентификатор NCT, чтобы попасть на нужную страницу, а не название препарата. Предположим, у вас есть два препарата, перечисленных в A1: B2, и правильный идентификатор NCT указан в столбце B

celebrex    NCT00571701
naproxen    NCT00586365

Чтобы использовать этот код, установите ссылку на библиотеку Microsoft XML 5.0 и библиотеку Microsoft Forms 2.0.

Sub GetClinical()

    Dim i As Long
    Dim lLast As Long
    Dim oHttp As MSXML2.XMLHTTP50
    Dim sHtml As String
    Dim lDataStart As Long, lTblStart As Long, lTblEnd As Long
    Dim doClip As DataObject

    'Find the last cell in column A
    lLast = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
    Set oHttp = New MSXML2.XMLHTTP50

    'Loop from the last cell to row 1 in column A
    For i = lLast To 1 Step -1
        'Insert 5 rows below
        Sheet1.Cells(i, 1).Offset(1, 0).Resize(5).EntireRow.Insert

        'get the web page
        oHttp.Open "GET", "http://clinicaltrials.gov/ct2/show/" & Sheet1.Cells(i, 2).Value & "?rank=1"
        oHttp.send
        sHtml = oHttp.responseText

        'Find the start and end to the table
        lDataStart = InStr(1, sHtml, "Estimated  Enrollment:")
        lTblStart = InStr(lDataStart - 200, sHtml, "<table")
        lTblEnd = InStr(lDataStart, sHtml, "</table>") + 8

        'put the table in the clipboard
        Set doClip = New DataObject
        doClip.SetText Mid$(sHtml, lTblStart, lTblEnd - lTblStart)
        doClip.PutInClipboard

        'paste the table as text
        Sheet1.Cells(i, 1).Offset(1, 0).Select
        Sheet1.PasteSpecial "Text", , , , , , True

    Next i

End Sub

Если у вас нет номеров NCT, я не думаю, что вы сможете создать работоспособный URL. Также обратите внимание, что я нахожу таблицу, ища определенную строку (Предполагаемая регистрация: - обратите внимание на два пробела между ними) и резервное копирование 200 символов. 200 произвольно, но работал как для знаменитостей, так и для напроксенов. Я не могу гарантировать, что их форматирование будет последовательным. Они не используют идентификаторы таблиц, поэтому сложно найти правильный.

Всегда делайте резервную копию ваших данных перед запуском кода, который их изменяет.

Answer 2

Если вы запустите поиск и посмотрите внизу страницы результатов, вы увидите, что есть возможность загружать результаты в различных форматах.Например, этот URL-адрес загрузит все результаты флуоксетина в формате табуляции с разделителями:

http://clinicaltrials.gov/ct2/results/download?down_stds=all&down_flds=all&down_fmt=tsv&term=fluoxetine

Единственное осложнение заключается в том, что результаты заархивированы, поэтому вам необходимо сохранить файл и распаковать его.К счастью для вас, мне уже пришлось это сделать ... Создайте папку с именем «files» в той же папке, что и ваша книга, затем добавьте этот код и протестируйте его.У меня работает нормально.

Option Explicit

Sub Tester()

    FetchUnzipOpen "fluoxetine"

End Sub

Sub FetchUnzipOpen(DrugName As String)
   Dim s, sz 'don't dim these as strings-must be variants!
   s = ThisWorkbook.Path & "\files"
   sz = s & "\test.zip"
   FetchFile "http://clinicaltrials.gov/ct2/results/download?down_stds=all&" & _
              "down_flds=all&down_fmt=tsv&term=" & DrugName, sz
   Unzip s, sz
   'now you just need to open the data file (files/search_result.txt)
End Sub


Sub FetchFile(sURL As String, sPath)
 Dim oXHTTP As Object
 Dim oStream As Object

    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    Set oStream = CreateObject("ADODB.Stream")
    Application.StatusBar = "Fetching " & sURL & " as " & sPath
    oXHTTP.Open "GET", sURL, False
    oXHTTP.send
    With oStream
        .Type = 1 'adTypeBinary
        .Open
        .Write oXHTTP.responseBody
        .SaveToFile sPath, 2 'adSaveCreateOverWrite
        .Close
    End With
    Set oXHTTP = Nothing
    Set oStream = Nothing
    Application.StatusBar = False

End Sub

Sub Unzip(sDest, sZip)
 Dim o
 Set o = CreateObject("Shell.Application")
 o.NameSpace(sDest).CopyHere o.NameSpace(sZip).Items
End Sub