医療用医薬品の一覧を取得するのは手間がかかる
医療用医薬品の業界は情報がきちんと整理されていないことが多く、必要な情報を取得するのに時間と手間がかかることが多いです。
私は医療用医薬品の原価管理・仕入管理などの仕事をしているのですが、ネットから情報を取得するのが面倒に感じることが多いです。
今回は私が仕事で使うために作った「JANコードから医薬品の規格単位や品名を取得するツール」をご紹介します。
（この記事は多くの人に使っていただけるツールというより、私が仕事のために作ったツールの備忘録としての意味が強いです。）
医療用医薬品の情報を記載されているサイト「医薬品コードサーチ」
医療用医薬品の情報を多く載せているサイトとして私がよく参考にしているのが、「医薬品コードサーチ」です。
無料で情報が取得できるサイトですので重宝するのですが、JANコードからの商品検索機能がないのが残念なところです。
今回私が紹介するツールではGoogle検索結果と医薬品コードサーチの情報を組み合わせることで、JANコードから医薬品名や規格単位などの情報を取得できるようにしています。
スポンサーリンク
医薬品情報を取得するExcelVBAサンプルコード
①医薬品の情報を他の包装単位含めてすべて取得するVBAコード
こちらのサンプルコードでは該当するJANコードの医薬品について他のJANコードの包装単位の情報含めすべて取得するものになります。
同じ医薬品でも複数のJANコードを持っているので、すべての情報を取得する際に役立ちます。
Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
Sub JANコードから医薬品情報一覧取得()
Dim i As Long, k As Long
Dim IE As Object
Dim Doc As Object
Dim anchor As Object
Dim tag
Set IE = CreateObject(“InternetExplorer.application”)
IE.Visible = True
i = 1
Do Until i > Cells(600000, 1).End(xlUp).Row
ループの最初:
tag = 0
IE.navigate (“https://www.google.co.jp/search?q=” & Cells(i, 1)) ’Google検索結果表示画面
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1000
Loop
Sleep 2000
For Each anchor In IE.document.getelementsByTagName(“A”)
If InStr(anchor, “icode-search.com/index.php?”) > 0 Then
anchor.Click
Do While IE.Busy Or IE.readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 2000
tag = 1
Exit For
End If
Next
If tag <> 1 Then
i = i + 1
GoTo ループの最初
End If
Const 抽出列 = 1000
Set Doc = IE.document
On Error Resume Next
c = 抽出列 + 1
r = 1
For y = 1 To Doc.all.Length
If Doc.all(y).tagName = “TH” Or Doc.all(y).tagName = “TD” Then
c = c + 1
Cells(r, c) = Doc.all(y).innerText
ElseIf Doc.all(y).tagName = “TR” Then
r = r + 1
c = 抽出列 + 1
End If
Next y
y = 10
Dim s
s = 0
Do Until Cells(y, 抽出列 + 4) = “”
Cells(i + s, 3) = Cells(2, 抽出列 + 3)
Cells(i + s, 4) = Cells(6, 抽出列 + 3)
Cells(i + s, 5) = Cells(y, 抽出列 + 2)
Cells(i + s, 6) = Cells(y, 抽出列 + 3)
Cells(i + s, 7) = Cells(y, 抽出列 + 4)
Cells(i + s, 8) = Cells(y, 抽出列 + 5)
s = s + 1
Range(Cells(i + s, 1), Cells(i + s, 2)).Insert shift:=xlDown
y = y + 1
Loop
Range(Cells(i + s, 1), Cells(i + s, 2)).Delete shift:=xlUp
Range(Columns(抽出列), Columns(抽出列 + 10)).ClearContents
On Error GoTo 0
i = i + s
Loop
IE.Quit
Set IE = Nothing
End Sub
Sub JANコードから医薬品情報一覧取得()
Dim i As Long, k As Long
Dim IE As Object
Dim Doc As Object
Dim anchor As Object
Dim tag
Set IE = CreateObject(“InternetExplorer.application”)
IE.Visible = True
i = 1
Do Until i > Cells(600000, 1).End(xlUp).Row
ループの最初:
tag = 0
IE.navigate (“https://www.google.co.jp/search?q=” & Cells(i, 1)) ’Google検索結果表示画面
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1000
Loop
Sleep 2000
For Each anchor In IE.document.getelementsByTagName(“A”)
If InStr(anchor, “icode-search.com/index.php?”) > 0 Then
anchor.Click
Do While IE.Busy Or IE.readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 2000
tag = 1
Exit For
End If
Next
If tag <> 1 Then
i = i + 1
GoTo ループの最初
End If
Const 抽出列 = 1000
Set Doc = IE.document
On Error Resume Next
c = 抽出列 + 1
r = 1
For y = 1 To Doc.all.Length
If Doc.all(y).tagName = “TH” Or Doc.all(y).tagName = “TD” Then
c = c + 1
Cells(r, c) = Doc.all(y).innerText
ElseIf Doc.all(y).tagName = “TR” Then
r = r + 1
c = 抽出列 + 1
End If
Next y
y = 10
Dim s
s = 0
Do Until Cells(y, 抽出列 + 4) = “”
Cells(i + s, 3) = Cells(2, 抽出列 + 3)
Cells(i + s, 4) = Cells(6, 抽出列 + 3)
Cells(i + s, 5) = Cells(y, 抽出列 + 2)
Cells(i + s, 6) = Cells(y, 抽出列 + 3)
Cells(i + s, 7) = Cells(y, 抽出列 + 4)
Cells(i + s, 8) = Cells(y, 抽出列 + 5)
s = s + 1
Range(Cells(i + s, 1), Cells(i + s, 2)).Insert shift:=xlDown
y = y + 1
Loop
Range(Cells(i + s, 1), Cells(i + s, 2)).Delete shift:=xlUp
Range(Columns(抽出列), Columns(抽出列 + 10)).ClearContents
On Error GoTo 0
i = i + s
Loop
IE.Quit
Set IE = Nothing
End Sub
②調査対象のJANコードについてのみ情報を取得するサンプルコード
こちらはJANコードに紐づいた包装単位を取得するVBAコードになります。
一つの医薬品について1行表示になるので、余分な情報を考えなくてよくなる分続いての処理が楽になります。
Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
Sub JANコードから規格単位検索()
Dim i As Long, k As Long
Dim IE As Object
Dim Doc As Object
Dim anchor As Object
Dim tag
Set IE = CreateObject(“InternetExplorer.application”)
IE.Visible = True
i = Selection.Row
IE.navigate (“https://www.google.co.jp/search?q=” & Cells(i, 1)) ’Googleの検索結果を表示する
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1000
Loop
Sleep 2000
For Each anchor In IE.document.getelementsByTagName(“A”)
If InStr(anchor, “icode-search.com/index.php?”) > 0 Then
anchor.Click
Do While IE.Busy Or IE.readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 2000
tag = 1
Exit For
End If
Next
If tag <> 1 Then
IE.Quit
Exit Sub
MsgBox “該当なし”
End If
Set Doc = IE.document
For k = 1 To Doc.all.Length － 1
If Doc.all(k).innerText = Cells(i, 1).Text Then
Cells(i, 4) = Doc.all(k － 2).innerText
Exit For
End If
Next k
IE.Quit
Set IE = Nothing
End Sub
Sub JANコードから規格単位検索()
Dim i As Long, k As Long
Dim IE As Object
Dim Doc As Object
Dim anchor As Object
Dim tag
Set IE = CreateObject(“InternetExplorer.application”)
IE.Visible = True
i = Selection.Row
IE.navigate (“https://www.google.co.jp/search?q=” & Cells(i, 1)) ’Googleの検索結果を表示する
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1000
Loop
Sleep 2000
For Each anchor In IE.document.getelementsByTagName(“A”)
If InStr(anchor, “icode-search.com/index.php?”) > 0 Then
anchor.Click
Do While IE.Busy Or IE.readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 2000
tag = 1
Exit For
End If
Next
If tag <> 1 Then
IE.Quit
Exit Sub
MsgBox “該当なし”
End If
Set Doc = IE.document
For k = 1 To Doc.all.Length － 1
If Doc.all(k).innerText = Cells(i, 1).Text Then
Cells(i, 4) = Doc.all(k － 2).innerText
Exit For
End If
Next k
IE.Quit
Set IE = Nothing
End Sub
おすすめ書籍 (広告)
Amazon 
楽天 
Yahoo検索
コメント