Webクエリで”次の10件”も自動で取り込むには？

質問

取り込むWeb上の表が１画面のみの場合は簡単なのですが、”次の10件”や”次のページ”よいった格好で、取り込みたい表（データ）が複数のページに及ぶ場合、そのデータをマクロ等で自動的に取り込むためにはどうしたらよいのですか？全部で1000件あるデータを取り込む場合、とても手作業で100回（1000件÷10件）も繰り返すのは現実的ではないため。

回答No.1

marbin · ベストアンサー

基本的には、ページ数を何らかの方法で取得して、URLを
固定部分+変数で指定してループさうるだけです。

↓はYahoo電話帳をウェブクエリで取得するサンプルです。
ただ、ちょいと不安定です。
>.Refresh BackgroundQuery:=False
でエラーになる可能性があります。

WEBクエリを使わずにWEBソースから内容を取得する方法も
ありますが、全てのHPで使えるわけではありません。

Option Explicit

Public myie As Object
Public kai1 As Integer
Public kai2 As Integer

Sub denwatyou()
Dim s As String
Dim kai As Integer
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim cnt As Long
Dim myrng As Range
Dim myurl As String
Dim motourl As String
motourl = "http://phonebook.yahoo.co.jp/list?a2=46201&g3=4467000"
Set myie = CreateObject("InternetExplorer.Application")
With myie
.navigate motourl
.Visible = True
While .Busy Or .readyState <> 4
Wend
Call numget
kai = kai2 \ kai1 + 1
For k = 1 To kai
Set myrng = Worksheets(1).Cells(65536, 1).End(xlUp).Offset(1)
'myurl = motourl & motourl & "&b=" & k & "&h=s"
'-----
If Right(motourl, 1) = "/" Then
myURL = motourl & "?b=" & k & "&h=s"
Else
myURL = motourl & "&b=" & k & "&h=s"
End If
'------
myie.navigate myurl
While myie.Busy Or myie.readyState <> 4
Wend
With ActiveSheet.QueryTables.Add(Connection:="URL;" & myurl, Destination:=myrng)
.Name = Split(motourl, "/")(3)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "11"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next k
End With
End Sub

Sub numget()
Dim Mybody As String
Dim s As Variant
Dim linestr As String
Dim i As Long
Dim cnt As Long
Dim MyDoc As Object 'MSHTML.HTMLDocument
Set MyDoc = myie.document
Mybody = MyDoc.body.innerHTML
s = Split(Mybody, vbCrLf)
cnt = UBound(s)
For i = 0 To cnt
linestr = s(i)
If linestr Like "*</B>件中<B>*" Then
kai2 = Split(Split(linestr, "<B>")(1), "</B>")(0)
kai1 = Split(Split(Split(linestr, "<B>")(2), "</B>")(0), "～")(1)
Exit For
End If
Next i
'myie.Quit
End Sub

お礼

回答ありがとうございます。
ただ、​http://phonebook.yahoo.co.jp/list?a2=46201&g3=4467000"​
にアクセスしたら
「指定されたURLは見つかりませんでした。」が出てきて、せっかくの回答内容を検証できません。

回答No.3

marbin

URLの不具合については、ちょうど別サイトでも話題になってました。
あえてURLはリンクしませんが、

「WEBからコピー時の特殊文字（？）の削除」

で検索したら見つかると思います。
まだ進行中の話題です。

URLをWEBからコピペするのでしたら参考になると思います。

また、IEで現在表示しているページのURLを取得するなら
こんなかんじいけます。
タイトルの取得も入れてあります。

Dim MyShell As Object, MyWindow As Object
Dim myurl As String
Dim mytitle As String
Set MyShell = CreateObject("Shell.Application")
For Each MyWindow In MyShell.Windows
If UCase(Right(MyWindow.FullName, 12)) = "IEXPLORE.EXE" Then
myurl = MyWindow.Locationurl
mytitle = MyWindow.document.Title
MsgBox myurl & vbCrLf & mytitle

End If
Next
Set MyShell = Nothing

回答No.2

marbin

WebからコピーしてそのままVBEに貼り付けてませんか？
そうするとURLの部分がおかしくなります。

テキストエディタにコードを貼り付けてみると、URLの部分
の前後に長さ0の文字列が挿入されているようです。
URLの部分を修正して実行してみてください。

※私のコードをVBEに貼り付けると、URLの部分が赤くなっているはずです。
この状態のときはおかしいと思ってください。

お礼

ありがとうございます。
上手く動きますね。
大変助かりました。
出力された表を見映えよく整えるくらいは自分でVBできますので、これからやります。

補足

たびたび申し訳ありません。
For i = 0 To cnt
linestr = s(i)
If linestr Like "*</B>件中<B>*" Then
kai2 = Split(Split(linestr, "<B>")(1), "</B>")(0)
kai1 = Split(Split(Split(linestr, "<B>")(2), "</B>")(0), "～")(1)
Exit For
End If
Next i
が全く理解できません。いくら検索しても、似たようなものにヒットしないため、さっぱりわかりません。"*</B>件中<B>*は一体何なのでしょうか？