競合ブログの目次取得ツール｜記事タイトル,H2,H3タグを順番にエクセルへ一覧にする(無料ダウンロード可能)

ブログの記事を書いている人の中には、競合サイトのブログ記事を調査（リサーチ）する人は多いです。

このリサーチ作業の目的は、競合ブログがどのようなキーワードを目次に入れているかを確認することにあります。

しかし重要なのは理解していていも、メンドウです。

●競合の記事調査は面倒くさい

・調査のとき、エクセルにコピペするのがメンドウ

・競合調査が多いと、どこまでコピペしたのか分からなくなる...

・でも、競合調査をしないと誰にも見られない記事になってしまう

そこで、競合ブログの記事の目次や記事タイトルを自動でエクセルに一覧にするツールを作成しました。

このツールを使うことで、以下のメリットがあります。

●記事情報自動取得ツールを使うメリット

・10秒で狙っているキーワードで上位表示されている記事の目次を確認できる

・記事検索、目次コピペなどのムダな作業がなくなる

・記事内の上から順番にH2タグやH3タグ（見出し）情報を取得してエクセルに一覧にしてくれる

それでは以下で詳しく説明していきます。

記事タイトル、目次（h2, h3）を自動取得するツールとは？

この記事ではエクセルVBAを使って、あるキーワードについてGoogle検索で上位表示される「検索順位」、「記事タイトル」、「H2タグ」、「H3タグ」の情報をエクセルに一覧にします。

以下が実際のツールの画像です。

このツールを使えば、上記の情報を簡単に取得できます。

目次取得ツールを動画で紹介

本記事で紹介するツールの機能と使い方はこちらの動画で紹介しています。

youtu.be

以下で、ツールの使い方やダウンロード方法を紹介します。

Googleで上位表示されている記事の情報を自動取得する！　ツールの使い方をステップで解説

ステップ1｜エクセル内のボタンを押す
ステップ2｜検索したいキーワードを入力する
ステップ3｜「OK」を押す

ステップ1｜エクセル内のボタンを押す

エクセル内に設置されている「キーワード調査」のボタンを押します。

ステップ2｜検索したいキーワードを入力する

ステップ1でボタンを押すと、以下のようなダイアログが出現します。

そのダイアログのテキストボックス（赤枠で囲われた部分）に検索したいキーワードを入力します。

ここでは、「社会人 勉強」というキーワードで上位表示されている記事の目次を調べることにします。

ステップ3｜「OK」を押す

スクレイピング結果が出力される

プログラムが稼働し、以下の結果が得られます。

記事の目次抽出ツールの追加機能

このツールでは、以下のような機能をつけています。

機能1｜B列の記事タイトルにハイパーリンクをつけている
機能2｜自動で保存される

機能1｜B列の記事タイトルにハイパーリンクをつけている

ハイパーリンクが自動出力されるため、エクセルのB列をクリックして記事へ開くことができます。

機能2｜自動で保存される

ツールの検索が終了すると、新しいエクセルファイルとして自動で保存されます。

保存先は、ツールが保存されているフォルダと同じ階層です。

記事の目次抽出ツールの注意点

このツールでは記事の目次がエクセルに出力されるように設計されています。

しかし記事の性質によっては、情報を取得できない場合があります。

実際、「社会人 勉強」のキーワードで情報を取得したとき、4位と10位の結果を取得できませんでした。

必ずしもすべての情報を取得できるわけではないことを理解してください。

またスクレイピングそのものは悪用しないようにし、このツールを使用するのは個人の責任の範囲でお願いします。

ウェブスクレイピングツールのプログラムソースコードはこちら

このツールは一言でいえば、ウェブスクレイピングアプリです。

おそらくこの記事を読んでいる人の中には、プログラミングの勉強をしている人もいるはずです。

そこで、この記事で紹介しているツールのプログラムソースを載せておきます。ぜひ何かの参考に使ってください。

Option Explicit
Dim ws1 As Worksheet

Sub AllProcedures()
    
    Dim KeyWord As String, KeyUrl As String
    Set ws1 = Worksheets("キーワード一覧")
    
    KeyWord = InputBox("調査したいキーワードを入力する")
    
    KeyUrl = "https://www.google.co.jp/search?q=" & KeyWord
    
    Call GetGoogleSuggestions(KeyUrl, KeyWord)
    
    ws1.Range("A4").Value = "検索キーワード：" & KeyWord
    
    Dim d As String
    
    KeyWord = Replace(KeyWord, "/", "")
    KeyWord = Replace(KeyWord, ":", "")
    
    d = Right(Replace(Date, "/", ""), 6)
    ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & d & "_" & KeyWord

End Sub

Sub GetGoogleSuggestions(KeyUrl, KeyWord)
    Set ws1 = Worksheets("キーワード一覧")
    Dim HttpReq As XMLHTTP60
    
    Set HttpReq = New XMLHTTP60
    HttpReq.Open "GET", KeyUrl
    HttpReq.send
    
    Do While HttpReq.readyState < 4
        DoEvents
    Loop
    
    Dim oHtml As New MSHTML.HTMLDocument
    Dim objTag As Object
    Dim PageTitle As String
    Dim ContentsURL As String
    Dim Counter As Long
    
    Counter = 1
    
    oHtml.body.innerHTML = HttpReq.responseText
      
    For Each objTag In oHtml.getElementsByTagName("a")
        
        If InStr(objTag.outerHTML, "LC20lb") > 0 Then
            PageTitle = objTag.innerText
            ContentsURL = objTag
            
            Call GetContentsEachPage(ContentsURL, PageTitle, Counter)
            Counter = Counter + 1
        End If
    Next

Continue:

    Set HttpReq = Nothing
    
End Sub
Sub GetContentsEachPage(ContentsURL As String, PageTitle As String, Counter As Long)
    
    Set ws1 = Worksheets("キーワード一覧")
    Dim objTag As Object
    Dim i As Long, j As Long, cmax As Long
    Dim cmax1 As Long, cmax2 As Long, cmax3 As Long
    Dim x As Long, p As Long, a As Long
    Dim myH2() As String, myH3() As String, myBody As Variant
    Dim Keys As Variant
    Dim myDic As Object
    Set myDic = CreateObject("Scripting.Dictionary")
    
    i = 0
    j = 0
    
    Dim HttpReq As XMLHTTP60
    Set HttpReq = New XMLHTTP60
    HttpReq.Open "GET", ContentsURL
    HttpReq.send
    
    Do While HttpReq.readyState < 4
        DoEvents
    Loop
    
    Dim oHtml As New MSHTML.HTMLDocument
    
    oHtml.body.innerHTML = HttpReq.responseText
        
    myBody = Split(oHtml.body.outerHTML, vbCrLf)

    
    For Each objTag In oHtml.getElementsByTagName("H2")
        ReDim Preserve myH2(i)
        myH2(i) = objTag.innerText
        i = i + 1
    Next
    
    
    For Each objTag In oHtml.getElementsByTagName("H3")
        ReDim Preserve myH3(j)
        myH3(j) = objTag.innerText
        j = j + 1
    Next
    
    For x = LBound(myBody) To UBound(myBody)
        
        If InStr(myBody(x), "H2") > 0 Or InStr(myBody(x), "H3") > 0 Then
        
            For i = LBound(myH2) To UBound(myH2)
                If InStr(myBody(x), myH2(i)) > 0 Then
                    myDic.Add "H2-" & x, myH2(i)
                    GoTo Continue
                End If
            Next
            
            For j = LBound(myH3) To UBound(myH3)
                If InStr(myBody(x), myH3(j)) > 0 Then
                    myDic.Add "H3-" & x, myH3(j)
                    GoTo Continue
                End If
            Next
                
Continue:
        End If
        
    Next
    
    cmax2 = ws1.Range("C1048576").End(xlUp).Row + 1
    cmax3 = ws1.Range("D1048576").End(xlUp).Row + 1
    
    cmax = cmax2
    
    If cmax3 > cmax2 Then
        cmax = cmax3
    End If
    
    ws1.Range("A" & cmax).Value = Counter
    
    With ws1
        .Range("B" & cmax).Value = PageTitle
        .Range("B" & cmax).WrapText = False
        .Hyperlinks.Add anchor:=.Range("B" & cmax), Address:=ContentsURL
    End With
    
    cmax = cmax + 1
    
    For Each Keys In myDic
        If Left(Keys, 2) = "H2" Then
            ws1.Range("C" & cmax).Value = myDic.Item(Keys)
            cmax = cmax + 1
        ElseIf Left(Keys, 2) = "H3" Then
            ws1.Range("D" & cmax).Value = myDic.Item(Keys)
            cmax = cmax + 1
        End If
    Next
 
    Set HttpReq = Nothing

End Sub

ダウンロードはこちら

使いたい人はこちらの問い合わせから「記事の目次取得ツールをDL希望」と連絡していただきたいです。

指定いただいたメールに、この記事で紹介しているツールを添付して返信します。