Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2010)
WEBデータをEXCELファイルに取り込む
投稿日時: 17/01/09 13:21:36
投稿者: shimoichimabu

EXCELファイルに薬品名、薬価などを記載したリストを作成しています。
しかし、薬価は毎年かわりますので、これを更新しなければいけません。
現在、「薬価サーチ」のWEBサイトを参照し、ここの最新薬価を手入力で
EXCELファイルに書き込んでいます。手間がかかり、誤入力のリスクもあります。
そこで、プログラムで「薬価サーチ」のサイトを開き、EXCELファイルの
薬品の頭4文字をキーワードとし、これで検索をかけ、製品名、製造会社、薬価、
規格をUSERFORMに取り込み、該当する薬品の薬価を選択し、EXCELファイルの
該当する薬品のセルに書き込むという流れを考えています。
但し、キーワード:「アトルバ」として検索をかけた場合、それに該当する
薬品が43品目あります。WEBページ1ページには30品目が表示されるので、
残りの13品目は次のページ>>>のボタンをおして参照することになるので、
このボタンを押す、コマンドもわかりません。
下記プログラムを書いてみました。ご助言の程、宜しくお願いいたします。
 
Sheets("採用薬").Select
     
Set objIE = CreateObject("InternetExplorer.Application")
strURL = "http://yakka-search.com/"
DATA末 = Cells(Rows.Count, "A").End(xlUp).Row
        
With objIE
    .Visible = True
    .Navigate strURL
         
    Do While .Busy = True
        DoEvents
    Loop
         
    Do While .document.ReadyState <> "complete"
        DoEvents
    Loop
         
    For Counter = 2 To DATA末 'Counter=2 データは2行目から開始
         
        薬価 = Trim(Range("F" & Counter).Value)
        KeyWord = Trim(Left(Range("A" & Counter).Value, 4))
             
        .document.all("key").Value = KeyWord '薬価サーチの検索入力欄に入力
         
        .document.forms(0).Submit '薬価サーチの検索ボタンを押す
                 
        Do While .Busy = True
            DoEvents
        Loop
         
        Do While .document.ReadyState <> "complete"
             DoEvents
        Loop
                 
        .Visible = False
          
        Set objTD = .document.GetElementsByTagName("TD")
        Set objPage = .document.GetElementsByClassName("page_view")
                 
        薬価Form.薬品ListBox.Clear
                
        For Each c In objTD  (1)
 
      薬価サーチ製品名 =??  ←ここのコマンドがわかりません
      薬価サーチ製造会社 =??
      薬価サーチ薬価 =??
      薬価サーチ規格 =??

         
            With 薬価Form.薬品ListBox
        .AddItem 薬価サーチ製品名
                .List(.ListCount - 1, 1) = 薬価サーチ製造会社
                .List(.ListCount - 1, 2) =薬価サーチ薬価
                .List(.ListCount - 1, 3) =薬価サーチ規格
            End With
     Next
        
   ここのコードをどこにはめ込むかは検討が必要
    ↓
        For Each Page In objPage
              
            If InStr(Page.innertext, "次の") > 0 Then
                「次のページ>>>」のボタンを押すコマンドがわかりません
                → プログラムで押した後、更に次ページのデータをUSERFORMに追記する
             
        Do While .Busy = True  ←ここのコード正しい・不要?
               DoEvents
            Loop
         
            Do While .document.ReadyState <> "complete"  ←ここのコード正しい・不要?
                DoEvents
            Loop
 
       Set objTD = .document.GetElementsByTagName("TD")  ←ここのコード正しい・不要?
        (1)の For Each c In objTD に戻る?
      End If
                     
        Next
                 
        薬価Form.Show
             
    Next
         
End With
--------------------------------
--------------------------------

回答
投稿日時: 17/01/09 18:13:09
投稿者: 半平太

このサイトは、READYSTATEがCompleteになるのに時間が掛かる様な気がします。
(いつまで経っても、先に行ってくれない)
 
待っていると時間が掛かってしょうがないので、
READYSTATE_INTERACTIVEになったら先に進んでしまい、
もし、それでトラブってデバッグモードに入ったら、
デバッグ画面に入ってF5キーで続行させた方がスピーディに行くような気がしました。
 
・・・なので、そう作ってあります。
 
この辺りの処理は、完璧な方法はありません。
使う人がどこで妥協するかです。そちらで色々トライしてみてください。
 

Sub PriceChecking()
    Dim objIE As Object 'InternetExplorer ' Object
    Dim strURL As String
    Dim DATA末 As Long, Counter As Long
    Dim objPage As Object, objTABLE As Object
    Dim 薬価, KeyWord
    Dim rowDATA As Object, cellData As Object
    Dim nextPage As Object
    Dim waitLimit
    
    Dim 薬価サーチ製品名
    Dim 薬価サーチ製造会社
    Dim 薬価サーチ薬価
    Dim 薬価サーチ規格

    Sheets("採用薬").Select
         
    Set objIE = CreateObject("InternetExplorer.Application")
    strURL = "http://yakka-search.com/"
    DATA末 = Cells(Rows.Count, "A").End(xlUp).Row
    
    With objIE
        .Navigate strURL
        .Visible = True
             
        waitLimit = [now()+"0:00:05"]
        
        Do While objIE.Busy = True Or objIE.ReadyState < READYSTATE_INTERACTIVE
          DoEvents
          If Now > waitLimit Then
            Exit Do
          End If
        Loop
             
        For Counter = 2 To DATA末 'Counter=2 データは2行目から開始
              
            薬価 = Trim(Range("F" & Counter).Value) '何に使うのか不明
            
            KeyWord = Trim(Left(Range("A" & Counter).Value, 4))
                 
            .Document.all("key").Value = KeyWord '薬価サーチの検索入力欄に入力
             
            .Document.forms(0).Submit '薬価サーチの検索ボタンを押す
            
            薬価Form.薬品ListBox.Clear
        
    Do  '次のページが終わるまで繰り返す
        .Visible = True
        waitLimit = [now()+"0:00:05"]
        
        Do While objIE.Busy = True Or objIE.ReadyState < READYSTATE_INTERACTIVE
          DoEvents
          If Now > waitLimit Then
            Exit Do
          End If
        Loop

            Set objTABLE = .Document.GetElementsByTagName("TABLE")
            Set objPage = .Document.GetElementsByClassName("page_view")
                    
            For Each rowDATA In objTABLE(0).Rows
                薬価サーチ製品名 = rowDATA.Cells(1).outertext
                    
                If Not 薬価サーチ製品名 Like "*製品名 ▲*" Then

'                    薬価サーチ製品名 = rowDATA.Cells(1).outertext
                    薬価サーチ製造会社 = rowDATA.Cells(3).outertext
                    薬価サーチ薬価 = rowDATA.Cells(4).outertext
                    薬価サーチ規格 = rowDATA.Cells(2).outertext
    '
                    With 薬価Form.薬品ListBox
                        .AddItem 薬価サーチ製品名
                        .List(.ListCount - 1, 1) = 薬価サーチ製造会社
                        .List(.ListCount - 1, 2) = 薬価サーチ薬価
                        .List(.ListCount - 1, 3) = 薬価サーチ規格
                    End With

                End If
             Next
            
             If InStr(objPage.Item.innertext, "次の") > 0 Then
                    Set nextPage = objPage.Item.GetElementsByTagName("a")
                    nextPage(0).Click
             Else
                Exit Do
             End If
       
            Loop
            
            .Visible = False
            
            薬価Form.Show
            AppActivate Application.Caption
        Next
       
        .Visible = True
    End With

    Set objIE = Nothing
End Sub

回答
投稿日時: 17/01/10 17:30:03
投稿者: kim358

半平太 様
 
IE制御にもいろいろ方法があるのですね、TABLE や nextpage は参考になりそうです。
 
私も仕事でIEを操作していますので役立たせていただきます。
 
コードを実行したところ、1ページしかない薬品の場合エラーになります。

If InStr(objPage.Item.innertext, "次の") > 0 Then    '←ここ、With ブロック・・・・
    Set nextPage = objPage.Item.GetElementsByTagName("a")
    nextPage(0).Click
Else
    Exit Do
End If

また、3ページ以上簿場合は、1ページ目、2ページ目、1ページ目、2ページ目と繰り返しに
なるようです。(nextPage(0)は、前のページになるようです)
 
For Each nextPage In objIE.document.GetElementsByTagName("A")
    If Left(nextPage.innerText, 5) = "次のページ" Then
        nextPage.Click
        Call IEwait(objIE)
        Exit For
    Else
        Set nextPage = Nothing           '次のページの有無スイッチ替わり
    End If
  Next
 If nextPage Is Nothing Then
     Exit Do
 End If

投稿日時: 17/01/10 19:49:46
投稿者: shimoichimabu

半平太さん、kim358さん回答ありがとうございます。
 
For Each rowDATA In objTABLE(0).Rowsについて
objTABLE(0) → objTABLE(1)にすると、
If Not 薬価サーチ製品名 Like "*製品名 ▲*" Then が不要となるのでは?
(何らかの理由でバグが発生した場合の回避策?)
*ちなみに、*製品名 ▲* の ▲は?
-----------------------------------------------------------------------
kim358さんのご指摘の通り、
If InStr(objPage.Item.innertext, "次の") > 0 Then の部分では
1ページのみの場合はエラーが発生することが試行した時、わかって
いましたが、3ページ以上簿場合は、1ページ目、2ページ目、
1ページ目、2ページ目と繰り返しになることはわかりませんでした。
kim358さんに下記のコードの仕組みを教えて下さい。
 
・次のページの有無スイッチ替わり とは?
・また、
   Else
        Set nextPage = Nothing となって、
更にIf nextPage Is Nothing Then となるので、私ではちょっと難解です。
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・   
   Else
        Set nextPage = Nothing '次のページの有無スイッチ替わり
     End If
   Next
 If nextPage Is Nothing Then
     Exit Do
 End If
 
宜しくお願い致します。

投稿日時: 17/01/10 23:13:47
投稿者: shimoichimabu

追記
 
下記のように、For Each 〜 Nextで回してありますが、
 
For Each nextPage In objIE.document.GetElementsByTagName("A")
    If Left(nextPage.innerText, 5) = "次のページ" Then
        nextPage.Click
        Call IEwait(objIE)
        Exit For
    Else
        Set nextPage = Nothing '次のページの有無スイッチ替わり
    End If
  Next
 If nextPage Is Nothing Then
     Exit Do
 End If
 
下記のようにIF 〜 Thenの形にできないかと
IF 〜 Then
 
Else
 
EndIf
 
向学のために、下記のようにトライしてみましたが、うまくできません。
やはり、無理でしようか?
 
On Error Resume Next
   If InStr(objPage.Item.innerText, "次の") = 0 Then
         Exit Do ← 1ページの場合、Exit Do が実行される
   Else
         Set nextPage = objPage.Item.GetElementsByTagName("a")
          nextPage.Click  ← 複数ページの場合、エラーは出ないが、機能していない!
    End If
On Error GoTo 0

回答
投稿日時: 17/01/11 08:33:02
投稿者: Abyss2

接近方法は異なりませんが、HTMLソースを調査すると
こんな風な書き方もあります。ご参考までに。
 

Private Declare Sub Sleep Lib "Kernel32" _
    (ByVal dwMilliseconds As Long)

Sub Main()
    Dim oIE As Object, oDoc As Object
    Dim oElem As Object, oTbl, oColl As Object
    Dim oCells As Object, oNN As Object
    Dim i&, ll&, idx&
    
    Set oIE = CreateObject("InternetExplorer.Application")
    oIE.Visible = True
    oIE.navigate "http://yakka-search.com/"
    
    WaitIE oIE
    
    Set oDoc = oIE.document
    Set oElem = oDoc.getElementsByTagName("input")(0)
    oElem.Value = "第一三共" ' 検索文字列
    oElem.form.submit
    
    Do
    
        WaitIE oIE
        
        Set oDoc = oIE.document
        Set oTbl = oDoc.getElementsByClassName("table021")(0)
        Set oColl = oTbl.Rows
        
        ll = oColl.Length
        If ll < 2 Then Exit Do
        For i = 1 To ll - 1
            idx = idx + 1
            Set oCells = oColl(i).Cells
            Cells(idx, 1).Resize(, 4).Value _
                = Array(oCells(1).getElementsByTagName("a")(0).innerText, _
                        oCells(3).innerText, _
                        oCells(4).innerText, _
                        oCells(2).innerText)
        Next
        
        Set oColl = oDoc.getElementsByClassName("page_right")
        Set oColl = oColl(0).getElementsByTagName("a")
        If oColl.Length = 0 Then Exit Do
        oColl(0).Click
        
    Loop
    
    'oIE.Quit
    
End Sub


' IEは別プロセスのためDoEvents効果はなし
Private Sub WaitIE(ByVal RHS As Object)
    While RHS.busy Or RHS.readystate <> 4&
        Sleep 100
    Wend
End Sub

回答
投稿日時: 17/01/11 10:54:46
投稿者: kim358

以下のように考えました。
 
'1itemごとに全itemをチェックします

For Each nextPage In objIE.document.GetElementsByTagName("A")  
    If Left(nextPage.innerText, 5) = "次のページ" Then
        '"次のページ"があったのでクリックして項目チェックを抜けます
        nextPage.Click
        Call IEwait(objIE)
        Exit For
    Else
        Set nextPage = Nothing           '"次のページ"は見つかっていない とします。
    End If
 Next
'全itemのチェックが終了してからか、"次のページ"があって For 〜 Next を抜けてきた
 If nextPage Is Nothing Then
     Exit Do           '"次のページ"が見つからずに抜けてきたので Do 〜 Loop を抜ける
 End If

 
------------------------------
On Error Resume Next
    If InStr(objPage.Item.innerText, "次の") = 0 Then
          Exit Do ← 1ページの場合、Exit Do が実行される
   Else
          Set nextPage = objPage.Item.GetElementsByTagName("a")  
     '何のITEMが選択されているのでしょうか
           nextPage.Click  ← 複数ページの場合、エラーは出ないが、機能していない!
    End If
 On Error GoTo 0
------------------------------

回答
投稿日時: 17/01/11 15:45:37
投稿者: kim358

shimoichimabu 様
 

引用:
下記のようにIF 〜 Thenの形にできないかと
IF 〜 Then
Else
EndIf

引用:
向学のために、下記のようにトライしてみましたが、うまくできません。
やはり、無理でしようか?
On Error Resume Next
If InStr(objPage.Item.innerText, "次の") = 0 Then
    Exit Do ← 1ページの場合、Exit Do が実行される
Else
    Set nextPage = objPage.Item.GetElementsByTagName("a")
    nextPage.Click  ← 複数ページの場合、エラーは出ないが、機能していない!
End If
On Error GoTo 0

 
 ↓ のようにするとうまくいくようです。
 
-----------------
On Error Resume Next
If InStr(objPage.Item.innertext, "次の") = 0 Then
    On Error GoTo 0
    Exit Do        'エラーで実行される
Else
    On Error GoTo 0        '"次の"があったので実行される
    Set nextPage = objPage.Item.GetElementsByTagName("a")
    If InStr(objPage.Item.innertext, "前の") = 0 Then
        nextPage(0).Click  '"前の"ページがない場合は (0)が"次のページ"で
    Else
        nextPage(1).Click  '"前の"ページがある場合は (0)が"前のページ"で
                           '(1)が"次のページ"になるようです。
    End If
End If
-----------------
[/quote]

回答
投稿日時: 17/01/11 21:33:19
投稿者: MMYS

薬価は門外漢ですが、ご提示のサイトもどこかの情報に基づいているはず。
つまり、元データは、厚生労働省の資料かと。
 
よくわかりせんけど、このデータは使えないのですか。
http://www.mhlw.go.jp/topics/2016/04/tp20160401-01.html
 

投稿日時: 17/01/13 00:32:11
投稿者: shimoichimabu

Abyss2さん
>HTMLソースを調査すると 、こんな風な書き方もあります
確かに、すっきりしていて参考になりました。
 
kim358さん
下記の方法も同様にうまく動作しました。ありがとうございました。
 
On Error Resume Next
If InStr(objPage.Item.innertext, "次の") = 0 Then
    On Error GoTo 0
    Exit Do        'エラーで実行される
Else
    On Error GoTo 0 '"次の"があったので実行される
    Set nextPage = objPage.Item.GetElementsByTagName("a")
    If InStr(objPage.Item.innertext, "前の") = 0 Then
        nextPage(0).Click '"前の"ページがない場合は (0)が"次のページ"で
    Else
        nextPage(1).Click '"前の"ページがある場合は (0)が"前のページ"で
                           '(1)が"次のページ"になるようです。
    End If
End If
 
MMYSさん
>薬価は門外漢ですが、ご提示のサイトもどこかの情報に基づいているはず。
>つまり、元データは、厚生労働省の資料かと。
喫は、最初はこのサイトのEXCELデータをダウンロードしてプログラムを作成しました。
EXCEL同志なので、この方がコーディングは楽でした。
しかし、たまたまアトルバスタチン「日医工」5mgと10mgが載っていないことがわかり、
日医工に確認したら、本薬剤は「統一名収載品」のため、「日医工」と銘打ったデータ
として、挙がっていないということでした。薬価サーチのサイトでは全てメーカー名が
載って出ているので、こっちの方のデータを使うことにしました。