在Excel上進行網站搜索

Question

我有一個excel電子表格和產品名稱列表。我想要做的是（1）將這些產品名稱分成5行，（2）設置一個從指定網站（clinicaltrials.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 ID才能進入正確的頁面，而不是藥物名稱。假設你有A1上市的兩種藥物：B2和適當的NCT ID是在B列

celebrex NCT00571701 
naproxen NCT00586365 

若要使用此代碼，設置對Microsoft XML 5.0庫的引用和Microsoft窗體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是任意的，但爲celebrex和naproxen工作。我無法保證他們的格式一致。他們不使用表格ID，因此很難找到合適的表格。

在運行修改它的代碼之前，請始終對數據進行備份。

Answer 2

如果您運行搜索並查看結果頁面的底部，則會看到可以選擇以各種格式下載結果。比如這個網址會下載所有的氟西汀的結果製表符分隔的格式：

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