パソコンスキルの教科書

パソコンスキルの教科書

東京大学大学院卒。博士課程に進学を志すも、担当教授と折が合わず、無職になる。医者を目指すも結局断念。田舎で派遣社員として働く。「スキルがなければ、仕事ももらえない」と悟り、ビジネススキルを学ぶ。プログラミング、英語を学び、一部上場企業へ転職。年間100時間以上の業務効率化を行い、社内講師に抜擢。海外の案件を担当し、数億円のプロジェクトに携わる。個人の事業でも、月売上100万を達成。現在は、自分の価値を高めるためのスキル向上支援を行う

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

ツール 記事 h2 h3 取得 自動 無料

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

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

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

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

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

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

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

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

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

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

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

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

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

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

記事タイトル、目次(h2, h3)を自動取得するツールとは?

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

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

f:id:gene320:20190428030719j:plain

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

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

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

youtu.be

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

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

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

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

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

f:id:gene320:20190428032153j:plain

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

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

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

f:id:gene320:20190428032519j:plain

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

f:id:gene320:20190428032905j:plain

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

f:id:gene320:20190428043510j:plain

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

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

f:id:gene320:20190428033529j:plain

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

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

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

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

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

f:id:gene320:20190428034937j:plain

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

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

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

f:id:gene320:20190428034224j:plain

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

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

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

実際、「社会人 勉強」のキーワードで情報を取得したとき、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希望」と連絡していただきたいです。

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