Excelでウェブサイトを検索

Question

私はスプレッドシートに製品名のリストを持っています。私がしたいのは、（1）これらの製品名を5行ずつ分離し、（2）特定のウェブサイト（clinicaltrials.gov）からデータを抽出し、各スプレッドシートの下の行に挿入するウェブサイト検索を設定することです。

（2）は、私にとって今のところはるかに重要で挑戦的です。私はすべての製品名を調べるループを実行しなければならないことを知っています。しかし、私がループに焦点を当てる前に、私はウェブサイトの検索を実行するコードを書く方法を理解する助けが必要です。

私が受け取ったいくつかの助け次のような

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

と出力4行：は

次のExcel VBAコードsnipetはの形で構築されたURLを持つセルがかかります

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が必要です。あなたは2つのA1に記載されている薬があるとします。B2、適切NCT IDは、このコードを使用するMicrosoft XML 5.0ライブラリへの参照を設定するには、列B

celebrex NCT00571701 
naproxen NCT00586365 

にあり、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を作成することはできません。また、特定の文字列（見積もり登録： - その間の2つのスペースに注意してください）を探し、200文字をバックアップしてテーブルを検索します。 200は任意ですが、celebrexとnaproxenの両方で働きます。彼らの書式が一貫しているとは保証できません。彼らはテーブルIDを使用しないので、正しいものを見つけるのが難しくなります。

データを変更するコードを実行する前に、常にデータのバックアップを作成してください。

Answer 2

検索を実行して結果ページの下部を見ると、さまざまな形式で結果をダウンロードするオプションが表示されます。

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

のみ合併症が結果はZIP形式であるということですので、あなたは、ファイルを保存し、それを最初に解凍する必要があります。たとえば、このURLは、タブ区切り形式ですべてのフルオキセチンの結果をダウンロードします。幸運なことに私はすでにこれをやろうとしていました...あなたのワークブックと同じフォルダに "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