Excel에서 웹 사이트 검색

Question

Excel의 스프레드 시트에 제품 이름 목록이 있습니다. 내가 원하는 것은 (1) 각 제품 이름을 5 행씩 분리하고 (2) 지정된 웹 사이트 (clinicaltrials.gov)에서 데이터를 추출하고 각 스프레드 시트 아래의 행에 채우는 웹 사이트 검색을 설정하는 것입니다.

(2)는 나에게 훨씬 중요하고 도전적입니다. 모든 제품 이름을 검토하는 루프를 실행해야한다는 것을 알고 있습니다. 그러나 루프에 집중하기 전에 웹 사이트 검색을 실행하는 코드를 작성하는 방법을 알아내는 데 도움이 필요합니다.

내가받은 도움 : 같은

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

그리고 출력 4 라인 :이

다음 엑셀 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가 필요합니다. 두 A1에 나와있는 약물이 가정 : B2 적절한 NCT ID 것은,이 코드를 사용하여 Microsoft XML 5.0 라이브러리에 대한 참조를 설정하려면 열 B

celebrex NCT00571701 
naproxen NCT00586365 

에 있으며 마이크로 소프트는 2.0 라이브러리를 형성한다. 당신이 NCT 번호가없는 경우

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 

, 나는 당신이 가능한 URL을 구성 할 수 있습니다 생각하지 않습니다. 또한 특정 문자열 (예상 등록 수 : - 두 개의 공백을 적어 두십시오)을 찾고 200자를 백업하여 테이블을 찾습니다. 200은 임의적이지만 celebrex와 naproxen 모두에서 효과가 있습니다. 서식의 일관성이 보장되지는 않습니다. 그들은 테이블 ID를 사용하지 않으므로 올바른 ID를 찾기가 어렵습니다.

데이터를 변경하는 코드를 실행하기 전에 항상 데이터를 백업하십시오.

Answer 2

검색을 실행하고 결과 페이지의 맨 아래를 보면 다양한 형식으로 결과를 다운로드 할 수있는 옵션이 표시됩니다.

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

유일한 합병증이 결과는 압축 된 것을, 그래서 당신은 파일을 저장하고 먼저 압축을 해제해야합니다 예를 들어 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