Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Sub NichibenrenSearch()
On Error GoTo continue
'行を数える
Dim dataCnt As Long 'データ数
dataCnt = Cells(Rows.Count, 2).End(xlUp).Row
Dim target As Long '検索対象の行
Dim startNum As Long '開始行
startNum = InputBox("開始行は？")
For target = startNum To dataCnt '開始行～データ数
'起動
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.navigate "https://www.nichibenren.jp/member_general/lawyerandcorpsearchselect/lawyerInfoSearchInput/"
Call WaitResponse(objIE)
'検索
Dim htmlDoc As HTMLDocument
Set htmlDoc = objIE.document
Dim targetLast As String
Dim targetFirst As String
targetLast = Cells(target, 2).Value
targetFirst = Cells(target, 3).Value
With htmlDoc
.getElementById("last_name").Value = targetLast
.getElementById("first_name").Value = targetFirst
.getElementById("doLawyerInfoSearch").Click
End With
Call WaitResponse(objIE)
'検索結果が0なら終了
If tagCheck(objIE, "class", "text-right", "0") = True Then
Cells(target, 6) = "◆該当なし"
GoTo continue
End If
'検索結果一覧の一番上へ遷移
'tableの2行目（tr(1)），2列目（td(1)），子（a）を取得。tdだけだとなぜかthもカウントされてうまくいかない
htmlDoc.getElementsByTagName("tr")(1).getElementsByTagName("td")(1).Children(0).Click
Call WaitResponse(objIE)
'詳細情報取得
'上の表
Dim table1 As Object
Set table1 = htmlDoc.getElementsByTagName("table")(0)
Dim x As Long '上の表の列
For x = 0 To 4 '5列分
Cells(target, x + 5) = table1.Rows(1).Cells(x).innerText '行（rows）は2行目で固定，列（cells）は変動
Next
'下の表
Dim table2 As Object
Set table2 = htmlDoc.getElementsByTagName("table")(1)
Dim y As Long '下の表の行
For y = 0 To 7 '8行分
Cells(target, y + 10) = table2.Rows(y).Cells(1).innerText '行（rows）は変動，列（cells）は2行目で固定
Next
continue:
objIE.Quit
Next
Beep
MsgBox "完了"
End Sub
Sub WaitResponse(objIE As Object)
Dim i As Long
For i = 0 To 10
Do While objIE.Busy = True Or objIE.readyState <> READYSTATE_COMPLETE '読み込み待ち
DoEvents
Loop
Sleep 100 '追加で待ってあげないとうまくいかない
Next
End Sub
Function tagCheck(objIE As InternetExplorer, _
methodType As String, _
elementName As String, _
keywords As String) As Boolean
Dim objDoc As Object, myDoc As Object
tagCheck = False
Select Case methodType
Case "name"
Set objDoc = objIE.document.getElementsByName(elementName)
Case "class"
Set objDoc = objIE.document.getElementsByClassName(elementName)
Case "tag"
Set objDoc = objIE.document.getElementsByTagName(elementName)
End Select
For Each myDoc In objDoc
If InStr(myDoc.outerHTML, keywords) > 0 Then
tagCheck = True
Exit For
End If
Next
End Function
