エクセルのWEBクエリで取り込めないデータ(続)

QNo6887062で教えていただいたWEBからデータを取り出すVBA(A15)で対象URLのレイアウトが変更になってしまいました。そこで引き続き活用したいため修正方法を教えていただければと思います。
URLの変更については一部対応できたのですが、取り出す範囲、除去する方法です。
具体的にはQ&Aの中で書きますので、上記VBAを修正できる方でお願いします。

Excel2010/WinXP

No.1 回答者： ki-aaa 回答日時： 2012/07/11 13:57

こんにちわ

試してみて

Sub use_XMLHTTP()
Dim myList As Range
Dim myRge As Range
Dim objHttp As Object
Dim strURL As String
Dim myTbl As Variant
Dim myWww As Variant
Dim i As Long, j As Long

Application.ScreenUpdating = False
With Sheets("Sheet2")
Set myList = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
Sheets("Sheet1").Columns("A:B").ClearContents

Set objHttp = CreateObject("MSXML2.XMLHTTP")

With objHttp
For Each myRge In myList
strURL = "http://www.st●●●igio.com/songlists/lists1/" & myRge.Value & ".html"
'Debug.Print strURL
.Open "GET", strURL, False
.Send

If (.Status < 200 Or .Status >= 300) Then
MsgBox strURL & " のページは見つかりませんでした。"
Else
myTbl = .responseText

myTbl = Split(myTbl, "<td class=""title"">")

j = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet1").Cells(j, 1).Value = "■■■" & strURL
For i = 1 To UBound(myTbl)
myWww = Split(myTbl(i), "</td><td>")
j = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet1").Cells(j, 1).Value = myWww(0)
Sheets("Sheet1").Cells(j, 2).Value = Left$(myWww(1), InStr(myWww(1), "<") - 1)
Next i
End If
Next myRge
End With
Set objHttp = Nothing
Application.ScreenUpdating = True

End Sub


●●●は元に戻してね

この回答へのお礼

ki-aaaさんこんにちわ
あいまいな質問なのに、対応してくださりありがとうございました。
さっそく試しましたが、以前のものと同じように普通のクエリより複数ファイルを早く一気に読み取れるのでぜひ使いたいです。

欲をいわせてもらえばチャンネルごとに別ファイルになると次の作業がやりやすいのですが、これはこのままでも工夫次第でなんとかなります。
ただ、保存フォームとして、元データはテーブルになっていると思いますが、途中のインデックス（例411だと「○年○月の…」はデータに必要なためぜひ入れたいです。
一応仕上がりとして各チャンネルの１列目(A列)は「■120709SD411」(411はCh名)と入れたいのと、各ブロックに上記インデックスの頭に「■」が入るようになればいいです。この■はインデックス欄のB列は空セルという条件で挿入VBAを組み入れることは教わったので自分でもできますが。

それから単純な疑問でurlが本来のものと違っていても読み込んでいるのですが、これはどこで判断しているのでしょうか。
このsonglist
の対象がちょっとややこしくて、ご覧いただいたように３つに分かれています。
左が先週、中央が今週、右が来週です。
先週は
igio.com/program/list/prg/prgid/411/2012/07/02/
今週は
igio.com/program/list/prg/prgid/411/
そして来週は（金曜17時以降日曜夜まで表示）
igio.com/program/list/prg/prgid/411/2012/07/09/
なのです。
必要なのは、金曜17時以降日曜夜までにDLする場合は「来週」のurlで、
その内容をほしい場合DLが月曜になってしまうと、その週のDLは「今週」のurlで同じ内容が必要でもurlがちょっと違ってしまうのです。

こんな状態をうまく使い分けられますか

お礼日時：2012/07/11 16:20

No.2 回答者： ki-aaa 回答日時： 2012/07/11 23:34

こんにちわ

抽出した内容はこれでよかったのかな。


>それから単純な疑問でurlが・・・
これは、前回の質問QNo6887062の中にに有ったものをそのまま使用しています。

補足では、マクロを実行する日時によりURLを変えて処理するように読み取れますが、
そのルールを整理して次のようします。

現在の時刻が、月曜の0時10分から金曜の16時50分までは、
"http://www.st●●●igio.com/program/list/prg/prgid/411/"

現在の時刻が、金曜の17時10分から日曜の23時50分までは、
"http://www.st●●●igio.com/program/list/prg/prgid/411/2012/07/09/"
・・・日付は、来週の月曜の日付

変わり目の時間帯は、アクセスできないようにします。

>欲をいわせてもらえばチャンネルごとに別ファイルになると
ファイル・・・エクセルのブックですよね
これも、ブックのパスや名前付けのルールがはっきり決まっていないと
それに、エクセルのバージョンが違いますので2003までので良ければ書きます。

>各チャンネルの１列目(A列)は「■120709SD411」
対応できます。

では、明日また

この回答への補足

「今週」のデータには、Now Playingというテーブルが本来リストの上に表示されます。これは読込みの対象外になりますのでよろしくお願いいたします。

補足日時：2012/07/12 10:09

この回答へのお礼

お手数をかけます。

>抽出した内容はこれでよかったのかな。
ANo1お礼に書いたように、曲グループ間のインデックスが入ればこれでいけます。（後記フォーム参照)

ファイル名はA1に入る「■120709SD***」（エクセルファイル）でお願いします。上書き回避の枝番があれば都合がいいです。
パスはこのファイルのある同じフォルダになります。

アドレスは曜日で対応してもらえると好都合です。

>それから単純な疑問でurlが・・・
過去のurlでもジャンプするようになっているようですね。これが常にこうなら曜日で使い分けないANo1のurlのままでもかまわないのですが、様子をみないとわかりません。

以上のように取り出しフォームは今まで行っている抽出後、再度他のシートでVBAを動かしているのでそれにあわせた形にしています。
A1「■120709SD***」(日付は抽出対象の月曜日)（今回抽出はurl+Ch)
A2曲のタイトルB2アーティスト（今回抽出した形)
A3、B3以下同じ（今回抽出した形)
途中（例）A10インデックス「■…」B10空白(追加)
A11,B11以降次の曲グループ（今回抽出した形)
途中（例）A20インデックス「■…」B20空白(追加)
A21,B21以降次の曲グループ（今回抽出した形)
以下Ch内繰り返し
(おわり)

お礼日時：2012/07/12 06:20

No.3 回答者： ki-aaa 回答日時： 2012/07/12 14:30

こんにちわ

>上書き回避の枝番があれば都合がいいです。
二つ目以降は名前の最後に、mmddを付けています。

URLですが、今週のものに日付が指定されていても大丈夫みたいなので、
すべて日付指定で、書いています。

>「今週」のデータには、Now Playingというテーブルが本来リストの上に表示されます。
>これは読込みの対象外になりますのでよろしくお願いいたします。
このようなデータは見かけないのですが?

Sub use_XMLHTTP()
Dim myList As Range
Dim myRge As Range
Dim objHttp As Object
Dim strURL As String
Dim myTbl As Variant
Dim myWww As Variant
Dim i As Long, j As Long
Dim 月曜日日付 As Date
Dim myStr As String

Application.ScreenUpdating = False

If Format(Date, "aaa") = "日" And Time > TimeValue("23:50:00") Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
ElseIf Format(Date, "aaa") = "月" And Time < TimeValue("00:10:00") Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
ElseIf Format(Date, "aaa") = "金" And _
(Time > TimeValue("16:50:00") And Time < TimeValue("17:10:00")) Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
End If

Select Case Weekday(Date, vbMonday)
Case Is <= 4 '月、火、水、木
月曜日日付 = Date - Weekday(Date, vbMonday) + 1
Case 5 '金
If Time < TimeValue("17:00:00") Then
月曜日日付 = Date - 4
Else
月曜日日付 = Date + 3
End If
Case Else '土、日
月曜日日付 = Date - Weekday(Date, vbMonday) + 8
End Select

With Sheets("Sheet2")
Set myList = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With


Set objHttp = CreateObject("MSXML2.XMLHTTP")

With objHttp
For Each myRge In myList

strURL = "http://www.stj●●●igio.com/program/list/prg/prgid/" & myRge.Value & _
"/" & Format(月曜日日付, "yyyy/mm/dd") & "/"

'Debug.Print strURL
.Open "GET", strURL, False
.Send

If (.Status < 200 Or .Status >= 300) Then
MsgBox strURL & " のページは見つかりませんでした。"
Else
myTbl = .responseText

myTbl = Split(myTbl, "<td class=""title"">")

Sheets("Sheet1").Columns("A:B").ClearContents
Sheets("Sheet1").Cells(1, 1).Value = "■" & Format(月曜日日付, "yymmdd") & _
"SD" & myRge.Value
For i = 1 To UBound(myTbl)
myWww = Split(myTbl(i), "</td><td>")
j = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet1").Cells(j, 1).Value = myWww(0)
Sheets("Sheet1").Cells(j, 2).Value = Left$(myWww(1), InStr(myWww(1), "<") - 1)
Next i

'2003まで2007以降は未チェック
'myStr = Dir(ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("A1").Value & ".xls")
myStr = Dir(ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("A1").Value & ".xlsx")
If myStr <> "" Then myStr = Format(Date, "_mmdd")
Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Range("A1").Value & myStr
ActiveWorkbook.Close
End If

Next myRge
End With
Set objHttp = Nothing
Application.ScreenUpdating = True

End Sub

この回答への補足

.sendで停止するといったのは間違いでした。アドレスをなおしていなかったためです。保存までうまくできましたがデフォルト（最初に動かすシートにもデータ読込が入ってしまうのでこれは不要と思われます。)
表示結果についてインデックスがまだ入っていませんでした。
インデックスとはテーブル間にあるグリーンのマークに続く文字列のことです。
よろしくお願いします。。

補足日時：2012/07/12 15:43

この回答へのお礼

色々条件が出てくるととてつもなく長くなっちゃうんですねぇ！（日にち指定だけがかなり複雑そうです）
手間をおかけしてすみません。
さて早速実行してみたのですが、途中.sendのところで
実行時エラー2146697211(800c0005)
システムエラー2146697211
になってしまいました。
このため、表示結果の確認はまだできていません。

それから、Nowplayingはwebのお知らせにあるように一時的に機能停止になっていて、9日以降に再開するというようなことが書かれていますが、まだ再開されていないようでした。なので実物がないので対応しようがないですね。すみません。ki-aaaさんとやりとりしている間に出てきたらよろしくお願いします。

あと、もし曜日に関係ない従来のアドレスが使えるとしたら、
ANo1の
myTbl = Split(myTbl, "<td class=""title"">")以下を
ANo3のものを同じ位置に使えばできますか。
Up等の曜日が変更することもありうるので両方対応しておこうと思っています。

それとまだ確認ができていないのでどのようになっているかわかりませんが
テーブルごとのインデックスには頭に■を入れたいのですが、「自分でできます」なんてえらそうなことを言ったのですが、どこの記述で入れるべきか、解読しきれません。いっしょにやってもらってよろしいでしょうか。
一応こんなつもりでいましたが。

For Each P In Range("A1", Cells(Rows.Count, 1).End(xlUp))
Select Case P.Offset(, 1).Value
Case "": v = "■" & P.Value
Case Else: v = P.Value
End Select
P.Offset(, 0).Value = v
Next P

お礼日時：2012/07/12 15:24

No.4 回答者： ki-aaa 回答日時： 2012/07/12 21:51

こんにちわ

>あと、もし曜日に関係ない従来のアドレスが使えるとしたら、・・・
これは忘れたほうがいいです。

>テーブルごとのインデックスには頭に■を入れたいのですが
これを425のウエブページで、詳しく説明してください。

>デフォルト（最初に動かすシートにもデータ読込が入ってしまうのでこれは不要と思われます。)
どうしても邪魔であれば、処理の最初でシートを作成し、処理の最後で削除する
または、シート3を使用する

ではまた明日。

この回答への補足

追記
>どうしても邪魔であれば

これはその都度「保存しない」で処理しますので問題ありません。

補足日時：2012/07/13 05:34

この回答へのお礼

４２５Chをクエリの自動記録で読み込んだものを加工して作っていたものですが、この仕上がりにしたいと思っています。(A1セルの表示はここではまだなおしていません)

Sub macro1WEBinsert()

Dim R As Long
Dim h1 As Range
Dim h2 As Range
Dim maxrow As Double
Dim i As Double
Dim P As Range
Dim v

'WEBクエリ
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.s●●●digio.com/program/list/prg/prgid/425", Destination:=Range _
("$A$1"))
.Name = "425"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

'下段削除
On Error Resume Next
R = Application.Match("*ページTOP*", Range("A:A"), 0)
Range(Cells(R, "A"), Range("A65536").End(xlUp)).EntireRow.Delete

'中間削除
Set h1 = Range("A:A").Find(What:="PROGRAM", LookIn:=xlValues, LookAt:=xlPart)
If h1 Is Nothing Then Exit Sub
Set h2 = Range("A:A").Find(What:="4：00～", after:=h1.Offset(2), LookIn:=xlValues, LookAt:=xlPart)
If h2 Is Nothing Then Exit Sub

Range(h1.Offset(2), h2).EntireRow.Delete

'上段削除
On Error Resume Next
Range("A1:A" & Application.Match("*PROGRAM*", Range("A:A"), 0)).EntireRow.Delete

maxrow = Cells(Rows.Count, 1).End(xlUp).Row

'タイトル削除
For i = maxrow To 1 Step -1
If InStr(Cells(i, 1), "曲名") > 0 Then
Rows(i).Delete
End If
Next i

'インデックス加工
Set c = Nothing
For Each P In Range("A1", Cells(Rows.Count, 1).End(xlUp))
Select Case P.Offset(, 1).Value
Case "": v = "■" & P.Value
Case Else: v = P.Value
End Select
P.Offset(, 0).Value = v
Next P

End Sub

お礼日時：2012/07/13 05:32

No.5 ベストアンサー 回答者： ki-aaa 回答日時： 2012/07/13 11:49

こんにちわ

>>あと、もし曜日に関係ない従来のアドレスが使えるとしたら、・・・
>これは忘れたほうがいいです。
これは、言葉足らずでした。ここで算出した日付を今週の日付として使用しています。
これを無くしますと、サイトの中から探す必要があります。

あなたの提示されたマクロでうまくいかなかった原因は
一部のサイトで、"4：00～"のデータが欠落していたからです。

URLを一部を変えている理由
大勢の人が、一斉にアクセスしないようにするためと、
MSXML2使ったダウンロードを喜ばないサイトもあります。

金曜日の17時前後のテスト、土日のテストもしてください。

Sub use_XMLHTTP()
Dim myList As Range
Dim myRge As Range
Dim objHttp As Object
Dim strURL As String
Dim myTp1, myTp2, myTp3
Dim i As Long, j As Long, k As Long
Dim 月曜日日付 As Date
Dim myStr As String

Application.ScreenUpdating = False

If Format(Date, "aaa") = "日" And Time > TimeValue("23:50:00") Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
ElseIf Format(Date, "aaa") = "月" And Time < TimeValue("00:10:00") Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
ElseIf Format(Date, "aaa") = "金" And _
(Time > TimeValue("16:50:00") And Time < TimeValue("17:10:00")) Then
MsgBox "いまの時間帯は、実行できません。"
Exit Sub
End If

Select Case Weekday(Date, vbMonday)
Case Is <= 4 '月、火、水、木
月曜日日付 = Date - Weekday(Date, vbMonday) + 1
Case 5 '金
If Time < TimeValue("17:00:00") Then
月曜日日付 = Date - 4
Else
月曜日日付 = Date + 3
End If
Case Else '土、日
月曜日日付 = Date - Weekday(Date, vbMonday) + 8
End Select

With Sheets("Sheet2")
Set myList = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With


Set objHttp = CreateObject("MSXML2.XMLHTTP")

With objHttp
For Each myRge In myList

strURL = "http://www.st●●●igio.com/program/list/prg/prgid/" & myRge.Value & _
"/" & Format(月曜日日付, "yyyy/mm/dd") & "/"

'Debug.Print strURL
.Open "GET", strURL, False
.Send

If (.Status < 200 Or .Status >= 300) Then
MsgBox strURL & " のページは見つかりませんでした。"
Else
myTp1 = .responseText
Sheets("Sheet1").Columns("A:B").ClearContents
Sheets("Sheet1").Cells(1, 1).Value = "■" & Format(月曜日日付, "yymmdd") & _
"SD" & myRge.Value
myTp1 = Split(myTp1, "<h3>")

For k = 1 To UBound(myTp1)
j = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet1").Cells(j, 1).Value = "■" & Left$(myTp1(k), InStr(myTp1(k), "<") - 1)

myTp2 = Split(myTp1(k), "<td class=""title"">")
For i = 1 To UBound(myTp2)
myTp3 = Split(myTp2(i), "</td><td>")
j = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet1").Cells(j, 1).Value = myTp3(0)
Sheets("Sheet1").Cells(j, 2).Value = Left$(myTp3(1), InStr(myTp3(1), "<") - 1)
Next i
Next k

'2003まで2007以降は未チェック
'myStr = Dir(ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("A1").Value & ".xls")
myStr = Dir(ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("A1").Value & ".xlsx")
If myStr <> "" Then myStr = Format(Date, "_mmdd")
Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Range("A1").Value & myStr
ActiveWorkbook.Close
End If

Next myRge
End With
Set objHttp = Nothing
Application.ScreenUpdating = True

End Sub

この回答への補足

こんにちわ
NowPlayingの件ですが、今日から再開されましたが幸いにして、欄外に表示されるようになりました。そのため読込み範囲に影響がないことになり、このまま修正の必要がなく利用することができそうです。
このたびは大変ご面倒をかけましたが丁寧に対応してくださりありがとうございました。
また、いつかご縁がありましたらよろしくお願いいたします。
（締め切り後に、万一継続質問が発生しましたら同じタイトルで質問を出させていただきますのでお目に止まっていただけることを願っています）

補足日時：2012/07/20 08:29

この回答へのお礼

おはようございます。
お礼が遅くなりました。
作っていただいたものについて各曜日ごとにチェックいたしました。
金曜日15.00(今週分2012.7.9のものを読込み)
金曜日17.00(実行不可)
金曜日18.00(翌週分2012.7.16のものを読込み)
土曜、日曜(翌週分2012.7.16のものを読込み)
月曜日05.00(今週分2012.7.16のものを読込み)
といずれの日においても意図のものを読み込むことができました。
インデックスや曲名はTAG(<h3>等)で判定しているのですね。

おかげさまで、これで今までどおりのことができるようになり感謝しています。
どうもありがとうございました。
なお、この間お話してある、NowPlayingのテーブルがまだ再開していないためしばらく閉鎖せずに、再開した段階で再度チェックしてみて修正が必要であれば引き続きお願いさせていただきたいと思いますのでよろしくお願いします。

>これを無くしますと、サイトの中から探す必要

たしかに以前のフォームだと、テーブルの中に放送日が入っていたため、そこから取り出すことができました。（現在のPDFの内容と同じスタイルでした)
私も現在のフォームになったとき日付の取り出しができなくなったので、開始時間の行に放送日を入れてほしい旨センターに頼んだのですが反応なしでした。

あとこれはほとんど必要ないと思いますが、たとえば先週の番組表を取り出したいときは、上のVBAとはまたかなり替えたものが必要になりますよね。
現在単発でできるVBAは、手直ししたものを作ってあるためそれを使えば間に合うのでそのときはそれを使うつもりですが。

お礼日時：2012/07/16 05:36