ブログの記事を書いている人の中には、競合サイトのブログ記事を調査（リサーチ）する人は多いです。
このリサーチ作業の目的は、競合ブログがどのようなキーワードを目次に入れているかを確認することにあります。
しかし重要なのは理解していていも、メンドウです。
・調査のとき、エクセルにコピペするのがメンドウ
・競合調査が多いと、どこまでコピペしたのか分からなくなる…
・でも、競合調査をしないと誰にも見られない記事になってしまう
そこで、競合ブログの記事の目次や記事タイトルを自動でエクセルに一覧にするツールを作成しました。
このツールを使うことで、以下のメリットがあります。
・10秒で狙っているキーワードで上位表示されている記事の目次を確認できる
・記事検索、目次コピペなどのムダな作業がなくなる
・記事内の上から順番にH2タグやH3タグ（見出し）情報を取得してエクセルに一覧にしてくれる
実際にキーワード調査の結果を出力したエクセルは以下のようになります。
それでは以下で使い方について詳しく説明していきます。
Contents
記事タイトル、目次（h2, h3）を自動取得するツールとは？
この記事ではエクセルVBAを使って、あるキーワードについてGoogle検索で上位表示される「検索順位」、「記事タイトル」、「H2タグ」、「H3タグ」の情報をエクセルに一覧にします。
以下の動画でツールを使用方法から得られる結果まで1分で確認できます。
このツールを使えば、動画のとおり上位表示されている記事の目次を簡単に取得できます。
以下で、ツールの使い方やダウンロード方法を紹介します。
Googleで上位表示されている記事の情報を自動取得する！ ツールの使い方をステップで解説
1｜エクセル内のボタンを押す
2｜検索したいキーワードを入力する
3｜「OK」を押す
ステップ1｜エクセル内のボタンを押す
エクセル内に設置されている「キーワード調査」のボタンを押します。
ステップ2｜検索したいキーワードを入力する
ステップ1でボタンを押すと、以下のようなダイアログが出現します。
そのダイアログのテキストボックス（赤枠で囲われた部分）に検索したいキーワードを入力します。
ここでは、「社会人 勉強」というキーワードで上位表示されている記事の目次を調べることにします。
ステップ3｜「OK」を押す
スクレイピング結果が出力される
プログラムが稼働し、以下の結果が得られます。
記事の目次抽出ツールの追加機能
このツールでは、以下のような機能をつけています。
1｜B列の記事タイトルにハイパーリンクをつける
2｜自動で保存される
機能1｜B列の記事タイトルにハイパーリンクをつけている
ハイパーリンクが自動出力されるため、エクセルのB列をクリックして記事へ開くことができます。
機能2｜自動で保存される
ツールの検索が終了すると、新しいエクセルファイルとして自動で保存されます。
保存先は、ツールが保存されているフォルダと同じ階層です。
記事の目次抽出ツールの注意点
このツールでは記事の目次がエクセルに出力されるように設計されています。
しかし記事の性質によっては、情報を取得できない場合があります。
実際、「社会人 勉強」のキーワードで情報を取得したとき、4位と10位の結果を取得できませんでした。
必ずしもすべての情報を取得できるわけではないことを理解してください。
またスクレイピングそのものは悪用しないようにし、このツールを使用するのは個人の責任の範囲でお願いします。
ウェブスクレイピングツールのプログラムソースコードはこちら
このツールは一言でいえば、ウェブスクレイピングアプリです。
おそらくこの記事を読んでいる人の中には、プログラミングの勉強をしている人もいるはずです。
そこで、この記事で紹介しているツールのプログラムソースを載せておきます。ぜひ何かの参考に使ってください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
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 |
注意1｜本ツールは完璧ではありません
本ツールは完璧なものではありません。たとえば、エラーでプログラムが止まったり、すべての目次を抽出できなかったりすることもあるはずです。
課題が発生したときは、ウェブで調査し自ら解決をしていってほしいと思います。
注意2｜悪用しないこと
こちらの記事でも記載されていますが、悪意のあるスクレイピングは罰則を受けることにつながるリスクがあります。
私は法律の専門家ではないため、詳しくは上記の記事に譲りますが、節度をもってスクレイピングを使用することをお願いいたします。
節度を持った使用とは、具体的には以下の3つです。「著作権法上の問題」、「利用規約との抵触」、「サーバーへの過度なアクセス」です。
この記事でスクリプトを公開している理由は、よりよい情報をユーザーに提供するために必要な情報収集の効率化です。
したがって、スクレイピングをする目的を考え、悪意のある使い方はしないことを推奨します。
以上のことをご理解いただいたうえで、本プログラムを使用ください。何かあった場合は私は責任を負いません。
ダウンロードはこちら
以下のフォームから本記事で紹介したマクロが入ったエクセルをダウンロードできるようにしました。
メールアドレスを入力いただくと、この記事で紹介しているエクセルを添付したメールが送信されます。
興味がある人はご活用ください。