VBAで学ぶ検索順位取得：Custom Search APIとスクレイピングの実践ガイド

Option Explicit

Private Const GOOGLE_API_KEY As String = "取得したAPIキー"
Private Const GOOGLE_CX_ID As String = "取得した検索エンジンID"
Private Const GOOGLE_SEARCH_URL As String = "https://www.googleapis.com/customsearch/v1"

Sub RankChecker()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim wkRow As Long, lngRank As Long
    Dim searchQuery As String

    If ws.Range("D1").Value < Date Then
        Call subSetHeadFormat(ws)
        Call subSetDetailFormat(ws)
    End If

    For wkRow = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        If ws.Cells(wkRow, 3) <> "" Then
            searchQuery = Trim(Replace(ws.Cells(wkRow, 3), "　", " "))
            lngRank = GetSearchResultRank(searchQuery, ws.Cells(wkRow, 2).Value)

            If lngRank > 0 Then
                ws.Cells(wkRow, 4).Value = lngRank
            Else
                ws.Cells(wkRow, 4).Value = "圏外"
            End If
        End If
    Next wkRow

    MsgBox "取得完了"
End Sub


Function GetSearchResultRank(searchQuery As String, targetURL As String) As Long
    Dim http As Object
    Dim json As Object
    Dim apiUrl As String
    Dim item As Object
    Dim i As Long, startIndex As Long
    Dim rank As Long

    rank = 0
    startIndex = 1

    Do While startIndex <= 10
        apiUrl = GOOGLE_SEARCH_URL & "?q=" & Application.WorksheetFunction.EncodeURL(searchQuery) _
                 & "&cx=" & GOOGLE_CX_ID & "&key=" & GOOGLE_API_KEY & "&lr=lang_ja&num=10&start=" & startIndex
        Debug.Print "APIリクエストURL: " & apiUrl

        Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
        http.Open "GET", apiUrl, False
        http.Send

        If http.Status <> 200 Then
            MsgBox "エラーのため取得できませんでした: " & http.statusText, vbExclamation
            Exit Function
        End If

        On Error Resume Next
        Set json = JsonConverter.ParseJson(http.responseText)
        On Error GoTo 0

        If Not json Is Nothing And json.Exists("items") Then
            For Each item In json("items")
                i = i + 1
                If item("link") = targetURL Then
                    rank = startIndex + i - 1
                    GetSearchResultRank = rank
                    Exit Function
                End If
            Next item
        Else
            Exit Do
        End If

        startIndex = startIndex + 10
        i = 0
    Loop

    GetSearchResultRank = 0
End Function


Private Sub subSetHeadFormat(ByVal ws As Worksheet)
    With ws
        .Columns("D").Insert
        .Columns("D").ColumnWidth = 4.8
        
        .Range("D1").Clear
        .Range("D1").NumberFormatLocal = "m/d"
        .Range("D1").HorizontalAlignment = xlCenter
        .Range("D1").Value = Now()
        .Range("D1").Interior.Color = RGB(32, 55, 100)
        .Range("D1").Font.Color = RGB(255, 255, 255)
        .Range("D1").Font.Bold = True
        
        .Columns("D").EntireColumn.AutoFit
    End With
End Sub

Private Sub subSetDetailFormat(ByVal ws As Worksheet)
    Dim tgRng As Range, myRng As Range
    Dim strAdr1 As String, strAdr2 As String

    With ws
        Set tgRng = .Range("A1").CurrentRegion
        Set tgRng = Intersect(tgRng, tgRng.Offset(1, 3))
    End With

    tgRng.FormatConditions.Delete
    For Each myRng In tgRng
        strAdr1 = myRng.Address(True, True)
        strAdr2 = 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 = "=IF(" & strAdr2 & " = """", " & strAdr1 & ", IF(AND(NOT(ISNUMBER(" & strAdr2 & ")), ISNUMBER(" & strAdr1 & ")), " & strAdr1 & " + 1, " & strAdr2 & "))"
                .Operator = 7
                .Icon = xlIconNoCellIcon
            End With
            With .IconCriteria(3)
                .Type = xlConditionValueFormula
                .Value = "=IF(AND(NOT(ISNUMBER(" & strAdr2 & ")), ISNUMBER(" & strAdr1 & ")), " & strAdr1 & " + 1, IF(" & strAdr2 & " = """", " & strAdr1 & ", " & strAdr2 & "))"
                .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

Option Explicit

Private driver As Selenium.WebDriver
Private Const cnsGUrl As String = "https://www.google.com/"

Sub RankCheker()
    '起動シートの初期処理
    Dim ws As Worksheet
    Set ws = ActiveSheet
  
    'Seleniumの初期処理
    Dim sKey As New Selenium.Keys
    Dim elm As Selenium.WebElement
    Dim wkRow&, lngRank&, wkStr$
    
    Set driver = New Selenium.WebDriver
    driver.AddArgument "--incognito" 'シークレットモード
    driver.Start "chrome"
    driver.Window.Maximize
    AppActivate Application.Caption
  
    
    With ws
    
        '前回実行日が前日以前なら履歴を残す
        If .Range("C1").Value < Date Then
            Call subSetHeadFormat(ws)
            Call subSetDetailFormat(ws)
        End If
        
        For wkRow& = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If ws.Cells(wkRow&, 2) <> "" Then
                driver.Get cnsGUrl
                AppActivate Application.Caption
                
                '検索語句はC列から取得
                wkStr$ = Trim(Replace(ws.Cells(wkRow&, 2), "　", " "))
                driver.FindElementByName("q").SendKeys(wkStr$).Value
                
                driver.FindElementByName("q").SendKeys sKey.Enter
                driver.Wait (2000)
          
                '検索結果からサイト掲載要素を取得
                Set elm = fncGetElement(ws.Cells(wkRow&, 1), lngRank&)
                
                If Not elm Is Nothing Then
                    .Cells(wkRow&, 3) = lngRank&
                Else
                    .Cells(wkRow&, 3) = "圏外"
                End If
            End If
        Next wkRow&
    
    End With
  
    '終了処理：Close,Quitは無くても良いけど
    driver.Close
    driver.Quit
    Set driver = Nothing
    
    MsgBox "取得完了"
    
End Sub

'概　要：指定したXPathの要素を取得：ページ内に無い場合は「次へ」
'引　数：piURL　検索するURL
'　　　　poRank 順位（戻り値のような扱い）
'戻り値：Selenium.WebElement
Private Function fncGetElement(ByVal piURL As String, ByRef poRank As Long) As Selenium.WebElement
                            
    Set fncGetElement = Nothing
    
    Dim elm As Selenium.WebElement
    Dim elms As Selenium.WebElements
    Dim myBy As New By
    Dim cntPage%
    Dim wkStr$
    
    cntPage% = 1
    poRank = 1
    
    On Error Resume Next
    
    Do
        'H3タグの一覧を取得
        Set elms = driver.FindElementsByXPath("//*[@id='rso']//h3")
        
        'H3タグ内のリンクを検索
        For Each elm In elms
            ' H3タグを含むセクション内のaタグを取得
            wkStr$ = elm.FindElementByXPath("ancestor::div[contains(@class, 'g')]//a").Attribute("href")
            
            'URLが一致するかを確認
            If wkStr$ = piURL Then
                ' 順位が判明したので、処理終了
                Set fncGetElement = elm
                Exit Function
            End If
            
            poRank = poRank + 1
        Next elm
    
        ' 5ページまで検索
        cntPage% = cntPage% + 1
        If cntPage% > 5 Then
            Exit Function
        End If
    
        ' 次へをクリック
        driver.FindElementByXPath("//*[@id='pnnext']/span").Click
        driver.Wait (2000)
    Loop
    
End Function

'日付履歴追加
Private Sub subSetHeadFormat(ByVal ws As Worksheet)
    
    With ws
        .Columns("C").Insert
        .Columns("C").ColumnWidth = 5
        
        .Range("C1").Clear
        .Range("C1").NumberFormatLocal = "m/d"
        .Range("C1").HorizontalAlignment = xlCenter
        .Range("C1").Value = Now()
        .Range("C1").Interior.Color = RGB(32, 55, 100)
        .Range("C1").Font.Color = RGB(255, 255, 255)
        .Range("C1").Font.Bold = True
        
        .Columns("C").EntireColumn.AutoFit
    End With

End Sub

'明細アイコンセットの設定
Private Sub subSetDetailFormat(ByVal ws As Worksheet)

    Dim tgRng As Range, myRng As Range
    Dim strAdr1 As String, strAdr2 As String

    With ws
        Set tgRng = .Range("A1").CurrentRegion
        Set tgRng = Intersect(tgRng, tgRng.Offset(1, 2))
    End With

    tgRng.FormatConditions.Delete
    For Each myRng In tgRng
        strAdr1 = myRng.Address(True, True)
        strAdr2 = 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 = "=IF(" & strAdr2 & " = """", " & strAdr1 & ", IF(AND(NOT(ISNUMBER(" & strAdr2 & ")), ISNUMBER(" & strAdr1 & ")), " & strAdr1 & " + 1, " & strAdr2 & "))"
                .Operator = 7
                .Icon = xlIconNoCellIcon
            End With
            With .IconCriteria(3)
                .Type = xlConditionValueFormula
                .Value = "=IF(AND(NOT(ISNUMBER(" & strAdr2 & ")), ISNUMBER(" & strAdr1 & ")), " & strAdr1 & " + 1, IF(" & strAdr2 & " = """", " & strAdr1 & ", " & strAdr2 & "))"
                .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