Yahoo検索結果をWebクエリを利用してエクセルにテーブル形式で抽出する。
手順
1.Yahoo検索結果をWebクエリによりシート1へ表示
↓Yahoo検索結果(エクセル vba)のWebクエリ
2.シート1の内容（いつもの検索結果の並び）をシート2へテーブル形式で並べ直す。
↓並び替え後
support.office.com
Sub Yahoo検索結果取得V1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Long, j As Long, k As Long, arr As Variant, flag As Boolean, HLA As String, Title As String, spage As Long
Dim URLstr As String, SN1 As String
sWord = InputBox("検索ワードを入力", "入力", "excel vba")
arr = Split(sWord)
sWord = UrlEncode(arr(0))
For i = 1 To UBound(arr)
sWord = sWord & "+" & UrlEncode(arr(i))
Next
k = 2
Call SheetAdd("Result")
SN1 = ActiveSheet.Name
With ActiveSheet
.Cells(1, 1) = "No"
.Cells(1, 1).ColumnWidth = 5
.Cells(1, 2) = "Title"
.Cells(1, 2).ColumnWidth = 20
.Cells(1, 3) = "URL"
.Cells(1, 3).ColumnWidth = 20
.Cells(1, 4) = "本文"
.Cells(1, 4).ColumnWidth = 20
End With
Call SheetAdd("Temporary")
SN2 = ActiveSheet.Name
spage = 1
URLstr = "https://search.yahoo.co.jp/search?p=" & sWord & "&aq=-1&ei=UTF-8&fr=top_ga1_sa&b=" & spage
With ActiveSheet.QueryTables.Add( _
Connection:="URL;" & URLstr, _
Destination:=Range("A1"))
.Name = "Result"
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.BackgroundQuery = False
.Refresh
End With
flag = False
HLA = ""
Title = ""
For i = 2 To ActiveSheet.UsedRange.Rows.Count
If InStr(Sheets(SN2).Cells(i, 1), "次へ>") > 0 Then
Exit For
End If
If Cells(i, 1).Hyperlinks.Count > 0 Then
On Error Resume Next
If InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "yahoo.co.jp") > 0 Or InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "cache.yahoofs.jp") > 0 Or InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "javascript") > 0 Then
Else
Title = Sheets(SN2).Cells(i, 1).Hyperlinks(1).TextToDisplay
HLA = Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address
If Title = "" Or HLA = "" Then
flag = False
Else
flag = True
End If
End If
On Error GoTo 0
Else
tst = Sheets(SN2).Cells(i, 1)
If flag = True Then
If Sheets(SN1).Cells(k - 1, 2).Value <> Title Then
Sheets(SN1).Cells(k, 1) = k - 1
Sheets(SN1).Hyperlinks.Add anchor:=Sheets(SN1).Cells(k, 2), _
Address:=HLA, _
TextToDisplay:=Title
Sheets(SN1).Cells(k, 3) = HLA
Sheets(SN1).Cells(k, 4) = tst
k = k + 1
End If
End If
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Function UrlEncode(ByVal TString As String) As String
Dim TempObj As Object
Dim TempEl As Object
TString = Replace(TString, "\", "\\")
TString = Replace(TString, "'", "\'")
Set TempObj = CreateObject("htmlfile")
Set TempEl = TempObj.createElement("span")
TempEl.setAttribute "id", "result"
TempObj.appendChild TempEl
TempObj.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & TString & "');", "JScript"
UrlEncode = TempEl.innerText
End Function
Sub SheetAdd(SNHead As String)
Dim mySheet As Worksheet
Dim i As Long, tst As String, flag As Boolean
For i = 1 To 100
flag = True
tst = SNHead & i
For Each mySheet In Worksheets
If mySheet.Name = tst Then
flag = False
End If
Next
If flag Then
Worksheets.Add
ActiveSheet.Name = tst
Exit Sub
End If
Next
End Sub
