Excel上的网站搜索

我在excel上有一个电子表格，上面有产品名称列表。我想做的是（1）将这些产品名称分成5行，（2）设置一个网站搜索，从给定网站（clinicaltrials.gov）中提取数据，并将其填充到每个电子表格下面的行中

（2） 现在对我来说更重要，更具挑战性。我知道我必须运行一个遍历所有产品名称的循环。但在我关注循环之前，我需要帮助弄清楚如何编写执行网站搜索的代码

我得到的一些帮助：

以下Excel VBA代码snipet将获取一个单元格，该单元格具有以下格式的构造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)

---

使用ActiveSheet.QueryTables.Add（连接：=_ ActiveCell.Text，目标：=单元格（ActiveCell.Row，ActiveCell.Column+1）） .Name=“临床试验” .FieldNames=True .rowNumber=False .FillAdjacentFormulas=False .PreserveFormatting=True .refreshinfoleopen=False .BackgroundQuery=True .RefreshStyle=xlInsertDeleteCells .SavePassword=False .SaveData=True .AdjustColumnWidth=True .RefreshPeriod=0 .WebSelectionType=xlSpecifiedTables .WebFormatting=xlWebFormattingNone .WebTables=“12” .WebPreFormattedTextToColumns=True .WebConsecutiveDelimiterSong=True .WebSingleBlockTextImport=False .WebDisableDateRecognition=False .WebDisableRedirections=False .Refresh BackgroundQuery:=False 以

---

你提供的URL无效。你需要NCT ID才能进入正确的页面，而不是药物名称。假设您有两种药物列在A1:B2中，正确的NCT id在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

Sub-GetClinical（）
我想我会坚持多久
暗驼一样长
作为MSXML2.XMLHTTP50的Dim oHttp
作为字符串的Dim sHtml
变暗lDataStart为Long，lTblStart为Long，lTblEnd为Long
Dim doClip作为数据对象
'查找A列中的最后一个单元格
lLast=Sheet1.单元格（Sheet1.Rows.Count，1）.结束（xlUp）.行
设置oHttp=New MSXML2.XMLHTTP50
'从最后一个单元格循环到A列的第1行
对于i=lLast至1步骤-1
'在下面插入5行
Sheet1.单元格（i，1）.偏移量（1，0）.调整大小（5）.EntireRow.Insert
'获取网页
oHttp.打开“获取”http://clinicaltrials.gov/ct2/show/&Sheet1.单元格（i，2）.值（&rank=1）
发送
sHtml=oHttp.responseText
'找到表的起点和终点
lDataStart=InStr（1，sHtml，“预计入学人数：”）
lTblStart=InStr（lDataStart-200，sHtml，“如果您运行搜索并查看结果页面的底部，您将看到有一个选项可以下载各种格式的结果。例如，此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

你能提供一个样本药物名称，以便我能看到查询结果吗？
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