目次
VBAでHTTPリクエストを実行する前に準備しておくこと
1.VBEを開いて頂いて、「ツール」→「参照設定」
2.この二つのライブラリにチェックを入れて、OKをクリック
・Microsoft HTML Object Library
・Microsoft XML v6.0
VBA入りのエクセルファイルをダウンロード
紹介しているVBAプログラムをそのまま使いたい人は、以下のフォームからダウンロードできます。
登録したメールアドレスへVBA入りのファイルを送信します。
本プログラムの内容をそのまま使用可能です。ぜひお仕事にお役立てください。
VBAのプログラムソース解説
今回紹介するプログラムの概要は以下です。
|
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 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
Option Explicit Sub Yahoo_auction_data_syutoku() 'プログラム2｜ Dim keyword As String keyword = InputBox("ヤフオクで検索したいキーワードを入力") Call CheckSheet(keyword) Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = Worksheets("結果出力") 'シート「結果出力」をコピーして、コピーしてシート名を検索キーワードにする ws1.Copy before:=ws1 Set ws2 = ActiveSheet ws2.Activate ws2.Name = keyword '検索キーワードをセルC2に入れる ws2.Range("C2").Value = keyword 'プログラム3｜Google検索のurlを取得 Dim url As String url = "https://auctions.yahoo.co.jp/search/search?p=" & keyword & "&n=100" 'プログラム4｜HTTPリクエスト設定 Dim HttpReq As XMLHTTP60 Set HttpReq = New XMLHTTP60 'プログラム5｜URLで指定したウェブページの情報をGETリクエストで取得 With HttpReq .Open "GET", url .send End With 'プログラム6｜HTTPリクエストの読み込み完了を待つ Do While HttpReq.ReadyState < 4 DoEvents Loop 'プログラム7｜ウェブページの情報をテキストで取得 Dim oHtml As New MSHTML.HTMLDocument oHtml.body.innerHTML = HttpReq.responseText '出品数を20で割ったときの商を出すことで、「次へ」を何回クリックするか算出する Dim kensu As Object Set kensu = oHtml.getElementsByClassName("Tab__subText")(0) ws2.Range("C4").Value = kensu.innerText '出品中をTrueで識別 Dim flag As Boolean flag = True 'ヤフオクの出品ページを全て習得する Do url = Title_s(url, ws2, flag) Loop While url <> "" '落札済をFalseで識別 flag = False '落札済みの件数を取得 Dim objrakusatsu As Object Set objrakusatsu = oHtml.getElementsByClassName("SearchMode__closedLink")(0) url = objrakusatsu.href ws2.Range("C5").Value = Rakusatsu_Souba(url) '落札数を20で割ったときの商を出すことで、「次へ」を何回クリックするか算出する Do url = Title_r(url, ws2, flag) Loop While url <> "" 'このプログラムを動かした日時を入れる ws2.Range("G5").Value = Now 'プログラム10｜オブジェクト解放 'Set objTag = Nothing Set HttpReq = Nothing End Sub Function Title_r(ByRef url As String, ByVal ws2 As Worksheet, ByVal flag As Boolean) 'プログラム4｜HTTPリクエスト設定 Dim HttpReq As XMLHTTP60 Set HttpReq = New XMLHTTP60 'プログラム5｜URLで指定したウェブページの情報をGETリクエストで取得 With HttpReq .Open "GET", url .send End With 'プログラム6｜HTTPリクエストの読み込み完了を待つ Do While HttpReq.ReadyState < 4 DoEvents Loop 'プログラム7｜ウェブページの情報をテキストで取得 Dim oHtml As New MSHTML.HTMLDocument oHtml.body.innerHTML = HttpReq.responseText Dim cmax As Long cmax = ws2.Range("A1048576").End(xlUp).Row + 1 Dim objTag As Object, ObjPrice As Object, objInfo As Object, objLabel As Object For Each objTag In oHtml.getElementsByClassName("Product") Set objInfo = objTag.getElementsByClassName("Product__titleLink")(0) ws2.Range("A" & cmax).Value = cmax - 7 ws2.Range("B" & cmax).Value = objInfo.innerText ws2.Hyperlinks.Add anchor:=ws2.Range("B" & cmax), Address:=objInfo.href Set objInfo = Nothing '備考欄→出品中or落札済 If flag = True Then ws2.Range("C" & cmax).Value = "出品中" Else ws2.Range("C" & cmax).Value = "落札済" End If ws2.Range("D" & cmax).Value = "-" '落札価格 ws2.Range("E" & cmax).Value = objTag.getElementsByClassName("Product__priceValue")(0).innerText '入札数 ws2.Range("F" & cmax).Value = objTag.getElementsByClassName("Product__bid")(0).innerText '残り時間 ws2.Range("G" & cmax).Value = objTag.getElementsByClassName("Product__time")(0).innerText cmax = cmax + 1 Next Title_r = Tsugihe(oHtml) Set HttpReq = Nothing End Function Function Rakusatsu_Souba(url) 'プログラム4｜HTTPリクエスト設定 Dim HttpReq As XMLHTTP60 Set HttpReq = New XMLHTTP60 'プログラム5｜URLで指定したウェブページの情報をGETリクエストで取得 With HttpReq .Open "GET", url .send End With 'プログラム6｜HTTPリクエストの読み込み完了を待つ Do While HttpReq.ReadyState < 4 DoEvents Loop 'プログラム7｜ウェブページの情報をテキストで取得 Dim oHtml As New MSHTML.HTMLDocument oHtml.body.innerHTML = HttpReq.responseText Debug.Print url Dim rakusatsu As Object Set rakusatsu = oHtml.getElementsByClassName("SearchMode__title")(0) Rakusatsu_Souba = rakusatsu.innerText End Function Function Title_s(ByRef url As String, ByVal ws2 As Worksheet, ByVal flag As String) 'プログラム4｜HTTPリクエスト設定 Dim HttpReq As XMLHTTP60 Set HttpReq = New XMLHTTP60 'プログラム5｜URLで指定したウェブページの情報をGETリクエストで取得 With HttpReq .Open "GET", url .send End With 'プログラム6｜HTTPリクエストの読み込み完了を待つ Do While HttpReq.ReadyState < 4 DoEvents Loop 'プログラム7｜ウェブページの情報をテキストで取得 Dim oHtml As New MSHTML.HTMLDocument oHtml.body.innerHTML = HttpReq.responseText Dim cmax As Long cmax = ws2.Range("A1048576").End(xlUp).Row + 1 Dim objTag As Object, ObjPrice As Object, objInfo As Object, objpriceinfo As Object For Each objTag In oHtml.getElementsByClassName("Product") Set objInfo = objTag.getElementsByClassName("Product__titleLink")(0) ws2.Range("A" & cmax).Value = cmax - 7 ws2.Range("B" & cmax).Value = objInfo.Title ws2.Hyperlinks.Add anchor:=ws2.Range("B" & cmax), Address:=objInfo.href Set objInfo = Nothing '備考欄→出品中or落札済 If flag = True Then ws2.Range("C" & cmax).Value = "出品中" Else ws2.Range("C" & cmax).Value = "落札済" End If '現在と即決の価格 For Each ObjPrice In objTag.getElementsByClassName("Product__price") If InStr(ObjPrice.innerText, "現在") > 0 Then ws2.Range("D" & cmax).Value = Replace(ObjPrice.innerText, "現在", "") ElseIf InStr(ObjPrice.innerText, "即決") > 0 Then ws2.Range("E" & cmax).Value = Replace(ObjPrice.innerText, "即決", "") End If Next If ws2.Range("D" & cmax).Value = "" Then ws2.Range("D" & cmax).Value = "-" End If If ws2.Range("E" & cmax).Value = "" Then ws2.Range("E" & cmax).Value = "-" End If '入札数 ws2.Range("F" & cmax).Value = objTag.getElementsByClassName("Product__bid")(0).innerText '残り時間 ws2.Range("G" & cmax).Value = objTag.getElementsByClassName("Product__time")(0).innerText cmax = cmax + 1 Next Title_s = Tsugihe(oHtml) Set HttpReq = Nothing End Function 'ウェブページ内の「次へ」を自動クリックする関数 Function Tsugihe(response) As String 'Dim ObjCheck As String 'response.getElementsByClassName("Pager__list Pager__list--disable")(0).innerText Dim ObjSubmit As Object Set ObjSubmit = response.getElementsByClassName("Pager__list Pager__list--next")(0) If InStr(ObjSubmit.innerHTML, "<a class=""Pager__link""") > 0 Then Tsugihe = ObjSubmit.getElementsByTagName("a")(0).href Else Tsugihe = "" End If End Function Sub CheckSheet(s) '変数sがシート名と一緒になっていないことをチェック If s = "検索キーワード" Or s = "結果出力" Or s = "設定" Then MsgBox "検索キーワードがシート名と同じです" Exit Sub End If '同じ検索キーワードのシートがあれば、そのシートを削除 Dim ws As Worksheet For Each ws In Worksheets If ws.Name = s Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next End Sub Function GetPagination(response, ws2) '検索キーワードの出品数をカウントする Dim kensu As String kensu = response.getElementsByClassName("Tab__subText")(0).innerText kensu = Replace(kensu, "件", "") '出品数を取得 ws2.Range("C4").Value = kensu '出品数を20で割ったときの商を出すことで、「次へ」を何回クリックするか算出する GetPagination = 1 + Int(kensu) \ 100 End Function |
詳しい解説は省略します。
ウェブ情報を取得する事例
ウェブ情報を取得する事例は別ページでも紹介しています。
1. IE操作でウェブ情報を取得
2. HTTPリクエストでウェブ情報を取得
3. APIを使ってウェブ情報を取得
4. VBA以外のプログラミング言語でウェブ情報を取得
Excel VBAについて詳しく理解したいなら
VBAを活用すると、仕事を効率化できる幅を広げることができます。
たとえば私が実際にVBAを活用して効率化してきた作業は以下の記事で紹介しています。
興味がある人は以下の記事もご覧ください。
動画でも解説しています。
エクセルマクロVBAで出来ることを15の事例で紹介｜日常業務をラクにするヒントを見つけよう！
(音声が小さいので、ボリュームを上げてご覧いただければと思います)
VBAの勉強方法
私はプログラミング初心者からVBAを勉強を始めて少しずつレベルアップしていきました。
成長の過程は以下で紹介しています。
以下のリンクでは、私の経験から勉強にオススメの教材を紹介しています。
興味がある人はご覧ください。