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

ExcelマクロVBAの問題点と解決策、エクセルVBAの技術的解説
最終更新日:2019-06-22

VBA+SeleniumBasicで検索順位チェッカー(改)


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

VBAでSeleniumBasicを使って検索順位チェッカーを作ってみます。SEO対策として各キーワードでの検索順位チェックは欠かせませんが、簡単に使えてキーワードを大量に指定できる良いツールがなかなかありません。Google検索をスクレイピングすることは、Google利用規約に反する可能性があります。

Google検索をスクレイピングすることは、Google利用規約に反する可能性があります。
ここには技術解説としてVBAコードを掲載しますが、この利用を推奨しているものではありません。
掲載したVBAコードの利用については、個々のご判断でお願いします。

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


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

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

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

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

シート構成

マクロ VBA Selenium

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
    
    '10ページまで
    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でのタイマー処理(SetTimer,OnTime)
マクロでShift_JIS文字コードか判定する
Byte配列と文字コード関数について
VBA+SeleniumBasicで検索順位チェッカー(改)
Applicationを省略できるApplicationのメソッド・プロパティ一覧
PowerQueryの強力な機能をVBAから利用する方法
ShapesとDrawingObjectsの相違点と使い方
新規挿入可能なシート名の判定
VBAにおける配列やコレクションの起点について
VBAのマルチステートメント(複数のステートメントを同じ行に)
クリップボードに2次元配列を作成してシートに貼り付ける


新着記事NEW ・・・新着記事一覧を見る

SQL関数と演算子|SQL入門(12月1日)
データの取得:集約集計、並べ替え(DISTINKT,GROUP BY,ORDER BY)|SQL入門(11月30日)
データの取得:条件指定(SELECT,WHERE)|SQL入門(11月29日)
データの挿入:バルクインサート|SQL入門(11月28日)
データの挿入(INSERT)と全削除|SQL入門(11月26日)
テーブル名変更と列追加(ALTER TABLE)とテーブル自動作成|SQL入門(11月25日)
テーブルの作成/削除(CREATE TABLE,DROP TABLE)|SQL入門(11月24日)
データベースに接続/切断|SQL入門(11月23日)
SQLiteのインストール|SQL入門(11月22日)
SQL入門:VBAでデータベースを使う|エクセルの神髄(11月22日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.RangeとCellsの使い方|VBA入門
4.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.マクロって何?VBAって何?|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.空白セルを正しく判定する方法(IsEmpty,IsError,HasFormula)|VBA技術解説
10.ひらがな⇔カタカナの変換|エクセル基本操作



  • >
  • >
  • >
  • VBA+SeleniumBasicで検索順位チェッカー(改)

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


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



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