| getElementByID(“id”)･･･要素のIDを指定して単一の要素を取得 |
| getElementsByName(“name”)･･･要素のNameを指定して単一の要素を取得 |
| getElementsByTagName(“タグ名”)･･･要素のタグ名を指定して複数要素を取得 |
| getElementsByTagName(“タグ名”)(n)･･･要素のタグ名を指定して複数要素の中からn番目の要素を取得 |
| getElementsByClassName(“クラス名”)･･･要素のクラス名を指定して複数要素を取得 |
| getElementsByClassName(“クラス名”)(n)･･･要素のクラス名を指定して複数要素の中からn番目の要素を取得 |
| querySelector(“CSSセレクタ”)･･･CSSセレクタで要素を指定して複数要素の中から1番目の要素を取得 |
| querySelectorAll(“CSSセレクタ”)･･･CSSセレクタで要素を指定して複数要素を取得 |
| Dim search_result_list |
| Set search_result_list = oIE.Document.querySelectorAll(“.srg .rc”) |
Private Sub cmd調査_Click()
Dim r As Long
Dim lastRow As Long, lng検索No As Long, lngページ数 As Long
Dim str検索キー As String
With Worksheets(sheetName2)
For r = 1 To 5
If .Range("C" & r + 4).Value = "" Then
Exit Sub
End If
lng検索No = r
str検索キー = .Range("B" & r + 4).Value & " " & Replace(.Range("C" & r + 4).Value, "-", " ")
lngページ数 = 2
'Yahoo！ショッピング検索
Call set_Yahoo(lng検索No, str検索キー, lngページ数)
'安値順にソート
Call sort_Yahoo(lng検索No)
'Yahoo！ショッピング表示
Call set_Yahoo結果2(lng検索No, lngページ数)
'楽天検索
Call set_Rakuten2(lng検索No, str検索キー, lngページ数)
'安値順にソート
Call sort_Rakuten(lng検索No)
'楽天表示
Call set_Rakuten結果2(lng検索No, lngページ数)
Next
End With
MsgBox "完了"
End Sub
Private Sub CommandButton2_Click()
' Worksheets(sheetName2).Range("B5:C100").ClearContents
Worksheets(sheetName2).Range("E5:AN100").ClearContents
End Sub
Sub set_Yahoo(lng検索No As Long, str検索キー As String, lngページ数 As Long)
'######################################################################
'
' Yahoo!ショッピング内検索
'
'######################################################################
Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
Dim URL_search As String, strP As String, strV As String
Dim txtInput As HTMLInputTextElement
t = 0
'ブラウザのオープン
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
objIE.Visible = True
'IEで開く
objIE.Navigate searchURL_Y
Call IEWait2(objIE) '自作関数: IE待機用
Call WaitFor2(2) '自作関数: WaitFor2(t):t秒待機
'検索情報の自動入力
'検索BOX
Set txtInput = objIE.document.getElementById("ss_yschsp")
txtInput.Value = str検索キー
'送信ボタン押下
Set button = objIE.document.getElementById("ss_srch_btn")
button.Click
Call WaitFor2(2)
'表示ボタンの切り替え（列表示）
' Set button = objIE.document.querySelector(".Icon--list")
' button.Click
'サーチ結果のURL取得
URL_search0 = objIE.document.url
Application.ScreenUpdating = False
nn = 2 '各シートの2行目から書き出す
For k = 1 To lngページ数 'lngページ数まで検索する
'URLの設定
If k > 1 Then
URL_search = URL_search0 & "&b=" & 30 * k - 29
Else
URL_search = URL_search0
End If
objIE.Navigate URL_search
Call IEWait2(objIE)
Call WaitFor2(2)
'search_result に検索結果部分をページごとにリストとして格納
Dim search_result_list
Set search_result_list = objIE.document.querySelectorAll(".LoopList__item")
'search_result の個数分繰り返し処理
With Worksheets("Y" & lng検索No)
If search_result_list.Length = 0 Then Exit For
For i = 0 To search_result_list.Length - 1
If InStr(search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText, "中古") = 0 Then
.Cells(nn, 1).Value = k
.Cells(nn, 2).Value = i + 1
' .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText 'タイトル
.Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href 'URL
.Cells(nn, 4).Value = search_result_list.Item(i).querySelector("._2RweXo29absZ").innerText '店名
strV = search_result_list.Item(i).querySelector("._3Z3ly613XmPi").innerText '価格
strP = search_result_list.Item(i).querySelector("._2UkNjGl36tm2").innerText 'ポイント
strV = Replace(strV, ",", "")
strV = Replace(strV, "円", "")
.Cells(nn, 5).Value = Val(strV)
.Cells(nn, 6).Value = Mid(strP, InStr(strP, "（") + 1, InStr(strP, "ポ") - InStr(strP, "（") - 1)
t = t + 1
End If
nn = nn + 1
Next
End With
If t = 0 Then
Worksheets(sheetName2).Range("E" & r).Value = "見つかりませんでした。"
End If
Next
'IEクローズ
objIE.Quit
Set objIE = Nothing
Application.ScreenUpdating = True
End Sub
Sub sort_Yahoo(lng検索No As Long)
'######################################################################
'
' Yahoo!ショッピング内検索結果を安値でソート
'
'######################################################################
Dim lastRow As Long
With Worksheets("Y" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
Call .Range("A2:F" & lastRow).Sort( _
Key1:=.Range("E1"), _
Order1:=xlAscending)
End With
End Sub
Sub set_Rakuten(lng検索No As Long, str検索キー As String, lngページ数 As Long)
'######################################################################
'
' 楽天内検索
'
'######################################################################
Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
Dim URL_search As String, strP As String, strV As String
t = 0
'ブラウザのオープン
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
objIE.Visible = True
'IEで開く
objIE.Navigate searchURL_R
Call IEWait2(objIE) '自作関数: IE待機用
Call WaitFor2(2) '自作関数: WaitFor2(t):t秒待機
'検索情報の自動入力
'検索BOX
Set txtInput = objIE.document.getElementById("sitem")
txtInput.Value = str検索キー
'送信ボタン押下
Set button = objIE.document.getElementById("searchBtn")
button.Click
Call WaitFor2(2)
'サーチ結果のURL取得
URL_search = objIE.document.url
Application.ScreenUpdating = False
nn = 2 '各シートの2行目から書き出す
For k = 1 To lngページ数 'lngページ数まで検索する
'URLの設定
If k > 1 Then
URL_search2 = URL_search & "?p=" & k
Else
URL_search2 = URL_search
End If
On Error Resume Next
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.Navigate URL_search2
Call IEWait2(objIE)
Call WaitFor2(2)
'search_result に検索結果部分をページごとにリストとして格納
Dim search_result_list
Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
'search_result の個数分繰り返し処理
With Worksheets("R" & lng検索No)
If search_result_list.Length = 0 Then Exit For
For i = 0 To search_result_list.Length - 1
If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
.Cells(nn, 1).Value = k
.Cells(nn, 2).Value = i + 1
.Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href 'URL
.Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText '店名
strV = search_result_list.Item(i).querySelector(".important").innerText '価格
strP = search_result_list.Item(i).querySelector(".points").innerText 'ポイント
strV = Replace(strV, ",", "")
strV = Replace(strV, "円", "")
.Cells(nn, 5).Value = Val(strV)
.Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
t = t + 1
End If
nn = nn + 1
Next
End With
Next
'IEクローズ
objIE.Quit
Set objIE = Nothing
Application.ScreenUpdating = True
'MsgBox "完了"
End Sub
Sub set_Rakuten2(lng検索No As Long, str検索キー As String, lngページ数 As Long)
'######################################################################
'
' 楽天内検索
'
'######################################################################
Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
Dim URL_search As String, strP As String, strV As String
Dim txtInput As HTMLInputTextElement
Dim button As Object
t = 0
'ブラウザのオープン
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
objIE.Visible = True
'IEで開く
objIE.Navigate searchURL_R
Call IEWait2(objIE) '自作関数: IE待機用
Call WaitFor2(2) '自作関数: WaitFor2(t):t秒待機
'検索情報の自動入力
'検索BOX
Set txtInput = objIE.document.getElementById("common-header-search-input")
txtInput.Value = str検索キー
'送信ボタン押下
Set button = objIE.document.getElementsByClassName("button--15weO button--uGWy7 undefined")(0)
button.Click
Call WaitFor2(2)
'サーチ結果のURL取得
URL_search = objIE.document.url
Application.ScreenUpdating = False
nn = 2 '各シートの2行目から書き出す
For k = 1 To lngページ数 'lngページ数まで検索する
'URLの設定
If k > 1 Then
URL_search2 = URL_search & "?p=" & k
Else
URL_search2 = URL_search
End If
On Error Resume Next
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.Navigate URL_search2
Call IEWait2(objIE)
Call WaitFor2(2)
'search_result に検索結果部分をページごとにリストとして格納
Dim search_result_list
Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
'search_result の個数分繰り返し処理
With Worksheets("R" & lng検索No)
If search_result_list.Length = 0 Then Exit For
For i = 0 To search_result_list.Length - 1
If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
.Cells(nn, 1).Value = k
.Cells(nn, 2).Value = i + 1
.Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href 'URL
.Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText '店名
strV = search_result_list.Item(i).querySelector(".important").innerText '価格
strP = search_result_list.Item(i).querySelector(".points").innerText 'ポイント
strV = Replace(strV, ",", "")
strV = Replace(strV, "円", "")
.Cells(nn, 5).Value = Val(strV)
.Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
t = t + 1
End If
nn = nn + 1
Next
End With
Next
'IEクローズ
objIE.Quit
Set objIE = Nothing
Application.ScreenUpdating = True
'MsgBox "完了"
End Sub
Sub sort_Rakuten(lng検索No As Long)
'######################################################################
'
' Rakuten内検索結果を安値でソート
'
'######################################################################
Dim lastRow As Long
With Worksheets("R" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
Call .Range("A2:F" & lastRow).Sort( _
Key1:=.Range("E1"), _
Order1:=xlAscending)
End With
End Sub
'IE待機用関数
Public Sub IEWait2(ByRef objIE As Object)
Do While objIE.Busy Or objIE.readyState <> 4
DoEvents
Loop
End Sub
't[sec]待機させる関数
Public Sub WaitFor2(ByVal second As Integer)
Dim futuretime As Date
futuretime = DateAdd("s", second, Now)
While Now < futuretime
DoEvents
Wend
End Sub
Sub set_Yahoo結果(lng検索No As Long, lngページ数 As Long)
Dim lng行番号 As Long, i As Long
Dim lastRow As Long, rowNo As Long, strURL As String
'占有率表示
With Worksheets("Y" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
lng行番号 = lng検索No + 1
If lastRow > 1 Then
rowNo = .Range("D2:D" & lastRow).Find(str店名, LookAt:=xlWhole).Row
'モダンブルーの表示順位（M列）、価格（N列）、商品URL（O列）
Worksheets(sheetName).Range("M" & lng行番号).Value = .Range("B" & rowNo).Value
Worksheets(sheetName).Range("N" & lng行番号).Value = .Range("E" & rowNo).Value
strURL = .Range("C" & rowNo).Value
Worksheets(sheetName).Range("O" & lng行番号).Value = strURL
'URLにハイパーリンクをつける
Dim hyplink As Hyperlink
Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
Anchor:=Worksheets(sheetName).Range("O" & lng行番号), _
Address:=strURL)
For i = 2 To 6
'Q列（価格）、R列（店舗名）、S列（ポイント）
Worksheets(sheetName).Range("Q" & lng行番号).Value = .Range("E" & i).Value
Worksheets(sheetName).Range("R" & lng行番号).Value = .Range("D" & i).Value
Worksheets(sheetName).Range("S" & lng行番号).Value = .Range("F" & i).Value
lng行番号 = lng行番号 + 1
Next i
End If
End With
End Sub
Sub set_Yahoo結果2(lng検索No As Long, lngページ数 As Long)
Dim lng行番号 As Long, i As Long
Dim lastRow As Long, rowNo As Long, strURL As String, rngA As Range
'占有率表示
With Worksheets("Y" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
lng行番号 = lng検索No + 4
If lastRow > 1 Then
On Error GoTo myError
Set rngA = .Range("D2:D" & lastRow)
rowNo = rngA.Find(str店名, LookAt:=xlWhole).Row
'モダンブルーの表示順位（M列）、価格（N列）、商品URL（O列）
Worksheets(sheetName2).Range("W" & lng行番号).Value = .Range("B" & rowNo).Value
Worksheets(sheetName2).Range("X" & lng行番号).Value = .Range("E" & rowNo).Value
strURL = .Range("C" & rowNo).Value
Worksheets(sheetName2).Range("Y" & lng行番号).Value = strURL
'URLにハイパーリンクをつける
Dim hyplink As Hyperlink
Set hyplink = Worksheets(sheetName2).Hyperlinks.Add( _
Anchor:=Worksheets(sheetName2).Range("Y" & lng行番号), _
Address:=strURL)
For i = 0 To 4
'Q列（価格）、R列（店舗名）、S列（ポイント）
Worksheets(sheetName2).Cells(lng行番号, 26 + i * 3).Value = .Range("E" & i + 2).Value
Worksheets(sheetName2).Cells(lng行番号, 27 + i * 3).Value = .Range("D" & i + 2).Value
Worksheets(sheetName2).Cells(lng行番号, 28 + i * 3).Value = .Range("F" & i + 2).Value
Next i
End If
End With
Exit Sub
myError:
MsgBox "ヤフショの検索結果では、モダンブルーの商品は見つかりません。検索対象の品番を見直すか、検索ページ数を増やしてください。" '表示されます
End Sub
Sub set_Rakuten結果(lng検索No As Long, lngページ数 As Long)
Dim lng行番号 As Long, i As Long
Dim lastRow As Long, rowNo As Long, strURL As String
'占有率表示
With Worksheets("R" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
lng行番号 = lng検索No * 5 + 1
If lastRow > 1 Then
rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
'モダンブルーの表示順位（F列）、価格（G列）、商品URL（H列）
Worksheets(sheetName).Range("F" & lng行番号).Value = .Range("B" & rowNo).Value
Worksheets(sheetName).Range("G" & lng行番号).Value = .Range("E" & rowNo).Value
strURL = .Range("C" & rowNo).Value
Worksheets(sheetName).Range("H" & lng行番号).Value = strURL
'URLにハイパーリンクをつける
Dim hyplink As Hyperlink
Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
Anchor:=Worksheets(sheetName).Range("H" & lng行番号), _
Address:=strURL)
For i = 2 To 6
'J列（価格）、K列（店舗名）、L列（ポイント）
Worksheets(sheetName).Range("J" & lng行番号).Value = .Range("E" & i).Value
Worksheets(sheetName).Range("K" & lng行番号).Value = .Range("D" & i).Value
Worksheets(sheetName).Range("L" & lng行番号).Value = .Range("F" & i).Value
lng行番号 = lng行番号 + 1
Next i
End If
End With
End Sub
Sub set_Rakuten結果2(lng検索No As Long, lngページ数 As Long)
Dim lng行番号 As Long, i As Long
Dim lastRow As Long, rowNo As Long, strURL As String
'占有率表示
With Worksheets("R" & lng検索No)
lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
lng行番号 = lng検索No + 4
If lastRow > 1 Then
rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
'モダンブルーの表示順位（F列）、価格（G列）、商品URL（H列）
Worksheets(sheetName2).Range("E" & lng行番号).Value = .Range("B" & rowNo).Value
Worksheets(sheetName2).Range("F" & lng行番号).Value = .Range("E" & rowNo).Value
strURL = .Range("C" & rowNo).Value
Worksheets(sheetName2).Range("G" & lng行番号).Value = strURL
'URLにハイパーリンクをつける
Dim hyplink As Hyperlink
Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
Anchor:=Worksheets(sheetName2).Range("G" & lng行番号), _
Address:=strURL)
For i = 0 To 4
'（価格）、（店舗名）、（ポイント）
Worksheets(sheetName2).Cells(lng行番号, 8 + i * 3).Value = .Range("E" & i + 2).Value
Worksheets(sheetName2).Cells(lng行番号, 9 + i * 3).Value = .Range("D" & i + 2).Value
Worksheets(sheetName2).Cells(lng行番号, 10 + i * 3).Value = .Range("F" & i + 2).Value
Next i
End If
End With
End Sub
Public Const searchURL_R = "https://www.rakuten.co.jp/"
Public Const searchURL_Y = "https://shopping.yahoo.co.jp/"
Public Const sheetName = "最安値調査"
Public Const sheetName2 = "改善案"
Public Const str店名 = "モダンブルーYahoo!店"
Public Const str店名2 = " モダンブルー楽天市場店"
