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

質問

WEBデータをVBAで取り込みたいと思っていますが、
次のサイトをWEBクリエで取り込もうとしてもデータ内容が取り込ません。
WEBによって取り込めない場合もあるのでしょうか。
また取り込む方法は他にありますか。

※取り込みたいデータ
http://www.stardigio.com/songlists/lists1/401.html

回答No.15

DOUGLAS_

＞今度のテストは呼び込みがおっそろしく早いですねぇ!
　そうでしょう。
　ですから、「今朝、画期的な方法を思い付」いたと書いた次第です。

＃この スレッド をご参考にされる方もあろうかと存じますので、この点につきまして、少し注釈しておきます。
＃当初は、「ＩＥオブジェクト」というものを使っていましたが、最近では、もっと読み込みの早い「WinHttp」という オブジェクト を使う場面がよく見受けられます。
＃私は最初から、この「WinHttp」を利用して試行してみたのですが、如何せん文字化けが酷くて。。。
＃恐らく「charset」関連の プロパティ か何かがあるのでしょうが、それを検索する元気がありませんでした。
＃ところが、似たような オブジェクト で「XMLHTTP」というものがあるのですが、こちらで読み込んでみますと、何と、文字化けせずに読み込めるではありませんか！・・・というようなことに、今朝、気付いたのです。

--------------------------------------------------

＞関数についてはご指示どおり排除してけっこうです。
＞日付の次はすべてSD（半角）になります。
　了解いたしました。

＞１行目を ■110725SD401に変えて
＞開始時間の行は削除対象のものでした。
＞したがって上記は１行目だけでかまいません。
　ということは、
「番組案内　（４時間サイクル）」
の部分も必要ないということでよろしいでしょうか？

　必要ないと判断してそういう プログラム を書きます。
　ただし、「必要な場合は」の注釈も付けておきます。

　ということで、今まで提示された条件を下記に列挙し、下記の点について成就する マクロ を文末に掲げます。

１）何も入力されていない新規の ブック に「Sheet1」・「Sheet2」という２つの ワークシート があります。

２）Sheet2 Ａ列 に羅列された「400 ～ 499」の整数に対して、順次、
http://www.stardigio.com/songlists/lists1/{整数部分}.html
の ページ を読み込み リスト 部分の データ を Sheet1 の A1 セル から貼り付けます。

３）貼り付けられるべき データ の内、
Ch.４０１ Ｊ－ＰＯＰ最新ヒットチャート
放送日 ： ２０１１／７／２５～２０１１／７／３１ 「番組案内　（４時間サイクル）」
開始時間 ： 04:00～08:00～12:00～16:00～20:00～24:00～
の３行は、「■110725SD401」の１行だけに集約します。

４）途中の「楽曲タイトル　演奏者名」の行と空白行、及び、文末の
＊個人的に楽しむ場合を除き、著作権上、無断複製は禁じられています。
＊FAXサービスは、（月）午前中入替作業の為、午後以降のご利用をお願い致します。御了承下さい。
の行はすべて削除します。

５）(２) ～ (４) により成形された データ が、Ａ・Ｂ列に書かれた ワークシート を マクロ の書かれた ブック と同じ フォルダ内 に「401_20110725.xlsx」という ファイル名 で保存します。

'-------------------------------------------------

Sub use_XMLHTTP()
　Dim myList As Range
　Dim objHttp As Object
　Dim myCh As Variant
　Dim strURL As String
　Dim str404 As String
　Dim myTbl As Variant
　Dim CB As New DataObject
　Application.ScreenUpdating = False
　Sheets("Sheet2").Select
　Rows(1).Insert
　Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　Set myList = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
　Set objHttp = CreateObject("MSXML2.XMLHTTP")
　With objHttp
　　Sheets("Sheet1").Select
　　For myCh = 1 To myList.Count
　　　strURL = "http://www.stardigio.com/songlists/txtdata/lists1/" & myList(myCh) & ".txt"
　　　.Open "GET", strURL, False
　　　.Send
'　　 読み込みエラー が出るようでしたら、この下の「’」を外してください。
'　　 Application.Wait (Now + TimeValue("0:00:05"))
　　　If (.Status < 200 Or .Status >= 300) Then
　　　　str404 = str404 & " " & myList(myCh)
　　　Else
　　　　myTbl = .responseText
　　　　myTbl = Split(myTbl, "放送日")
　　　　myTbl(0) = Left(myTbl(1), InStr(myTbl(1), "～"))
　　　　myTbl(0) = Trim(Replace(Replace(StrConv(myTbl(0), vbNarrow), ":", ""), "~", ""))
　　　　myTbl(0) = Format(myTbl(0), "yymmdd")
　　　　myTbl(0) = "■" & myTbl(0) & "SD401"
'　　　 貼り付けエラー が出るようでしたら、この下の「’」を外してください。
'　　　 Columns("A:B").Clear
　　　　With CB
　　　　　.SetText myTbl(0) & vbCr & Mid(myTbl(1), InStr(myTbl(1), "■"))
　　　　　.PutInClipboard
　　　　　.GetFromClipboard
　　　　End With
　　　　Range("A1").Select
　　　　ActiveSheet.Paste
　　　　On Error Resume Next
　　　　Columns("A:A").Find("個人的に楽しむ場合を除き").Resize(2).Clear
　　　　On Error GoTo 0
　　　　Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　　　　Range("A1").Select
　　　　Sheets("Sheet1").Copy
　　　　ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & _
　　　　　myList(myCh) & "Ch_(" & Replace(Date, "/", "") & ") .xlsx", _
　　　　　FileFormat:=xlOpenXMLWorkbook
　　　　ActiveWorkbook.Close
　　　End If
　　Next
　　Columns("A:B").Clear
　End With
　Set objHttp = Nothing
　Application.ScreenUpdating = True
　If str404 <> "" Then MsgBox Join(Split(str404), " Ch") & " のページは見つかりませんでした。"
End Sub

'-------------------------------------------------

＊「番組案内　（４時間サイクル）」の部分が必要な場合は、
.SetText myTbl(0) & vbCr & Mid(myTbl(1), InStr(myTbl(1), "■"))
の行を
.SetText myTbl(0) & Mid(myTbl(1), InStr(myTbl(1), vbTab))
に差し替え、
ActiveSheet.Paste
の後に、
Columns("A:A").Replace "楽曲タイトル", ""
を挿入してください。

==================================================

　上記の マクロ をお試しいただいて、まだ、不具合等がございましたら、どうぞ、仰ってください。

＃「前回」の件は、本件終了後にいたしましょう。

お礼

今回のVBAはまったく問題なく動作し、１０以上のchの取り込みも新幹線並のスピードで作成されました。
毎週25chのリストＵＰをしていたのですが、これならストレスなく簡単に作業できます。
これをもとにLotusで使っている関数をエクセル用に組み換える作業を自分でもやってみようと思っています。

なお、番組案内　（４時間サイクル）」はあったほうがいいかなと思い、修正の上やってみたのですがこちらだと不要な「開始時間」の行が残ってしまいました。

XMLHTTPについては早速サイトで調べて見たのですが、VBAそのものをよく理解できていない私にとってはなかなかむつかしい内容ですが、A1にあったようにJAVAを使ったサイト等に有効なんでしょうね。
わたしもLotus時代にマクロを作ったときに色々新しい手法を見つけてテストがうまく行くたびにマクロを作ることが楽しかったのですが、これだけ奥深いエクセルVBAを覚えればきっと同じような楽しさを味わえるのかもしれません。

補足

テストして気がついたのですが
１行目の「■110725SD401」はSDは固定ですがそのあとは該当Chの数字にしたいので、サイト元データの１行目にある白抜き数字の○○Chを当てはめていただければと思います。あわせて110725についてはサイト元データの２行目の放送開始日が入るようにしておいてください。（毎週変わります）
また、412ch以降で、当該chのデータが読み込まれた後に、411Chの一部が取り込まれているのに気がつきました。
たとえば
■80年代J-POPヒット曲と４回出てきたあと、
■2001年 7月のヒットコレクション PART 2
■2000年 7月のヒットコレクション PART 1
のデータが続いていました。
412ch以外でも見られます。