VBA+SeleniumBasicで検索順位チェッカー（改）

公開日：2019-06-02　最終更新日：2019-06-22

VBA+SeleniumBasicで検索順位チェッカー（改）

VBAでSeleniumBasicを使って検索順位チェッカーを作り、Google検索順位の履歴を管理します、
既に作成解説した、VBA+SeleniumBasicで検索順位チェッカー作成 こちらの改訂版になります。

・シート構成・検索順位チェッカーのVBA全コード・最後に

Google検索をスクレイピングすることは、Google利用規約に反する可能性があります。

ここには技術解説としてVBAコードを掲載しますが、この利用を推奨しているものではありません。
掲載したVBAコードの利用については、個々のご判断でお願いします。

SEO対策として各キーワードでの検索順位チェックは欠かせませんが、
複数のキーワードの検索順位を履歴で見やすく管理しできるようにしています。

今回は技術解説というより、VBA+SeleniumBasic実践編サンプルとしての位置づけになります。

改訂内容

・シートのレイアウト
・Chromeシークレットモード
・エレメントの取得方法
・順位変化をアイコンセット

順位履歴が見やすいようにレイアウト変更
Google順位変動が激しくなっているので、厳密に判定したいのでシークレットモードで起動
Google結果表示が時々で変化するので、より汎用的に変更
一目で分かり安いようにイコンセットで視覚化

※検索されているのに「圏外」となってしまうバグもあったので修正されています。

シート構成

C1：サイトURL
A4～：キーワード（個数制限なし）
B3：取得日時
B4～：検索結果に掲載されているページタイトル
C4～：検索結果に掲載されているページURL
D列：今回順位
E列以降：前日以前の順位履歴

検索順位チェッカーのVBA全コード


  
    
      Option Explicit


Private Driver As Selenium.WebDriver

Private Const gUrl As String = "https://www.google.co.jp/"

'検索ボックスのCSS selector

Private Const gSearch As String = "#tsf > div:nth-child(2) > div > div.RNNXgb > div > div.a4bIc > input"


      Sub RankCheker()

　　'起動シートの初期処理

　　Dim ws As Worksheet

　　Set ws = ActiveSheet

　　Dim siteUrl As String

　　siteUrl = ws.Range("C1") 'サイトURL

　　

　　'Seleniumの初期処理

　　Dim sKey As New Selenium.Keys

　　Dim elm As Selenium.WebElement

　　Set Driver = New Selenium.WebDriver

　　Driver.AddArgument "--incognito" 'シークレットモード

　　Driver.Start "chrome"

　　Driver.window.Maximize

　　AppActivate Application.Caption

　　

　　Dim i As Long, cntRank As Long

　　Dim myRng As Range

　　Dim sAdr1 As String, sAdr2 As String

　　With ws

　　　　

　　　　'前回実行日が前日以前なら履歴を残す

　　　　If .Range("D3").Value < Date Then

　　　　　　Call setHeadFormat(ws)

　　　　　　Call setDetailFormat(ws)

　　　　End If

　　　　.Range("D3").Value = Now()

　　　　

　　　　'出力範囲を初期クリア

　　　　.Range("A3").CurrentRegion.Offset(1, 1).Resize(, 3).ClearContents

　　　　For i = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row

　　　　　　Driver.Get gUrl

　　　　　　AppActivate Application.Caption

　　　　　　Set elm = Driver.FindElementByCss(gSearch)

　　　　　　

　　　　　　'検索ボックスへキーワード送信

　　　　　　elm.Clear

　　　　　　elm.SendKeys .Cells(i, 1)

　　　　　　elm.SendKeys sKey.Enter

　　　　　　

　　　　　　'検索結果からサイト掲載要素を取得

　　　　　　Set elm = getElement(siteUrl, _

　　　　　　　　　　　　　　　　.Cells(i, 1).Value, _

　　　　　　　　　　　　　　　　cntRank)

　　　　　　If Not elm Is Nothing Then

　　　　　　　　.Cells(i, 2) = elm.FindElementByTag("h3").Text

　　　　　　　　.Cells(i, 3) = Mid(elm.Attribute("href"), Len(siteUrl) + 1)

　　　　　　　　.Cells(i, 4) = cntRank

　　　　　　Else

　　　　　　　　.Cells(i, 4) = "圏外"

　　　　　　End If

　　　　Next

　　　　

　　End With

　　

　　'終了処理：Close,Quitは無くても良いけど

　　Driver.Close

　　Driver.Quit

　　Set Driver = Nothing

　　MsgBox "取得完了"

End Sub


'指定selectorの要素を取得：ページ内に無い場合は「次へ」

Private Function getElement(ByVal siteUrl As String, _

　　　　　　　　　　　　　　ByVal sCss As String, _

　　　　　　　　　　　　　　ByRef cntRank As Long) _

　　　　　　　　　　　　　　As Selenium.WebElement

　　Set getElement = Nothing

　　Dim elm As Selenium.WebElement

　　Dim elms As Selenium.WebElements

　　Dim sHref As String

　　Dim cntPage As Long

　　cntRank = 0

　　On Error Resume Next

　　Do

　　　　'検索結果表示領域全体

　　　　Set elm = Driver.FindElementByCss("#rso")

　　　　If Err Then Exit Function

　　　　'明細は<div class="g">で繰り返されている

　　　　Set elms = elm.FindElementsByClass("g")

　　　　If Err Then Exit Function

　　　　If elms.Count = 0 Then Exit Function

　　　　For Each elm In elms

　　　　　　Set elm = elm.FindElementByClass("r").FindElementByTag("a")

　　　　　　If Err Then

　　　　　　　　Err.Clear

　　　　　　Else

　　　　　　　　If sHref <> elm.Attribute("href") Then

　　　　　　　　　　cntRank = cntRank + 1

　　　　　　　　　　If elm.Attribute("href") Like siteUrl & "*" Then

　　　　　　　　　　　　Set getElement = elm

　　　　　　　　　　　　Exit Function

　　　　　　　　　　End If

　　　　　　　　　　sHref = elm.Attribute("href")

　　　　　　　　End If

　　　　　　End If

　　　　Next

　　　　

　　　　'１０ページまで

　　　　cntPage = cntPage + 1

　　　　If cntPage >= 10 Then

　　　　　　Exit Function

　　　　End If

　　　　

　　　　Driver.FindElementByLinkText("次へ").Click

　　　　If Err Then

　　　　　　Exit Function

　　　　End If

　　Loop

End Function


'日付履歴追加

Private Sub setHeadFormat(ByVal ws As Worksheet)

　　Dim tgRng As Range, myRng As Range

　　Dim sAdr1 As String, sAdr2 As String

　　With ws

　　　　.Columns("D").Insert

　　　　.Columns("D").ColumnWidth = 4.6

　　　　.Range("D1").Clear

　　　　.Range("D1").NumberFormatLocal = "0"

　　　　.Range("D3").NumberFormatLocal = "m/d"

　　　　.Range("D3").HorizontalAlignment = xlCenter

　　　　.Range("D3").Value = Now()

　　End With

End Sub


'明細アイコンセットの設定

Private Sub setDetailFormat(ByVal ws As Worksheet)

　　Dim tgRng As Range, myRng As Range

　　Dim sAdr1 As String, sAdr2 As String

　　

　　With ws

　　　　Set tgRng = .Range("A3").CurrentRegion

　　　　Set tgRng = Intersect(tgRng, tgRng.Offset(1, 3))

　　End With

　　

　　tgRng.FormatConditions.Delete

　　For Each myRng In tgRng

　　　　sAdr1 = myRng.Address(True, True)

　　　　sAdr2 = myRng.Offset(, 1).Address(True, True)

　　　　With myRng.FormatConditions.AddIconSetCondition

　　　　　　.IconSet = ws.Parent.IconSets(xl3TrafficLights1)

　　　　　　.IconCriteria(1).Icon = xlIconGreenUpArrow

　　　　　　With .IconCriteria(2)

　　　　　　　　.Type = xlConditionValueFormula

　　　　　　　　.Value = "=" & sAdr2

　　　　　　　　.Operator = 7

　　　　　　　　.Icon = xlIconNoCellIcon

　　　　　　End With

　　　　　　With .IconCriteria(3)

　　　　　　　　.Type = xlConditionValueFormula

　　　　　　　　.Value = "=IF(" & sAdr2 & "=""""," & sAdr1 & "," & sAdr2 & ")"

　　　　　　　　.Operator = 5

　　　　　　　　.Icon = xlIconRedDownArrow

　　　　　　End With

　　　　End With

　　　　With myRng.FormatConditions.Add(Type:=xlExpression, Formula1:="=ISTEXT(" & myRng.Address(False, False) & ")")

　　　　　　.Interior.Color = vbYellow

　　　　End With

　　Next

      End Sub

動作が安定しないときは、画面切り替わり直後に適宜待ち時間を入れてください。
Driver.Wait ミリ秒

短時間に大量の検索を行うとエラーになります。
Google検索のスクレイピングはGoogle利用規約に反する可能性もあり、
過度な検索実行は控えてください。

最後に

掲載したVBAについては、ご自由に改変してお使いください。

当初作成より見やすくなったと思います。
今後の課題としては、
エクセルなので、定時起動してのチェックができないのが一番の悩みです。
GAS(Google Apps Script)ならトリガーで簡単に実現できるので今後検討したいと思っています。

同じテーマ「マクロVBA技術解説」の記事

VBAでのSQLの基礎（SQL:Structured Query Language）
VBAで正規表現を利用する（RegExp）
VBAでメール送信する（CDO:Microsoft Collaboration Data Objects）
VBAでのOutlook自動操作
 ADO(ActiveX Data Objects)の使い方の要点
 特殊フォルダの取得（WScript.Shell,SpecialFolders）
参照設定、CreateObject、オブジェクト式の一覧
 VBAのスクレイピングを簡単楽にしてくれるSelenium
VBA+SeleniumBasicで検索順位チェッカー作成
VBA+SeleniumBasicで検索順位チェッカー（改）
.Net FrameworkのSystem.Collectionsを利用

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門

ホーム
マクロVBA応用編
マクロVBA技術解説
VBA+SeleniumBasicで検索順位チェッカー（改）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA技術解説
VBA+SeleniumBasicで検索順位チェッカー（改）