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

質問

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

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

回答No.7

DOUGLAS_

念のために書かせていただきますが、使い古しの ブック に新しい シート を追加するのでは意味がありません。

１）新しい ブック を開きます。
２）その ブック に 標準モジュール を追加します。
３）マクロ の コード を「ここ」から コピペ します（手書きは絶対ダメです。誤記の元です）。
４）「Microsoft Forms 2.0 Object Library」に参照設定します。
５）マクロ を動かします。

　以上が、こういうところの コード を試す基本かと存じます。

　ひょっとしたら、Excel の バージョン がいたずらをしているのかも知れませんので、その場合は原因を確かめようがありません（私は 2003 です。）

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

　先ず、下記の サンプルを、上記 (１) ～ (５) の段取りでお試しください。

Sub テスト()
　Dim objIE As Object
　Dim myTbl As String
　Dim CB As New DataObject
　Set objIE = CreateObject("InternetExplorer.Application")
　With objIE
　　.Navigate "http://www.stardigio.com/songlists/lists1/401.html"
　　.Visible = True
　　'上手く行けば、「401Ch」の ページ が表示されます。
　　Application.Wait (Now + TimeValue("0:00:2"))
　　myTbl = objIE.Document.getElementsByName("SongLists")(0).outerHTML
　　MsgBox myTbl
　　'上手く行った場合は、「<div id="SongLists"・・・」というような メッセージ が表示されます。
　　.Quit
　End With
　Set objIE = Nothing
　With CB
　　.SetText "こんにちは"
　　.PutInClipboard
　　.GetFromClipboard
　　MsgBox .GetText
　　'上手く行った場合は、「こんにちは」という メッセージ が表示されます。
　End With
End Sub

　上記の３点がすべて上手く行く場合は、「使い古しの ブック」が原因かも知れません。

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

　これより下は、上記が上手く行った場合にお試しください。

　サンプルコード を２つ掲載いたします。

Ａ】１つは、「ANo.3」を基本として、クリップボード オブジェクト を利用するものですが、「ANo.3」の コード の内、
myTbl = Left(myTbl, InStr(myTbl, "</table>") - 1) & "</table></div></div>"
の行を、
myTbl = Left(myTbl, InStr(1, myTbl, "<p class=""caption"">", vbTextCompare) - 1) & "</div>"
に差し替えてください。

　なお、原因が分かりませんが、「楽曲タイトル・演奏者名」の htmlコード を削除しても、その行が空白のまま表示されてしまいますので、『A列に「楽曲タイトル」（B列に「演奏者名」)という・・・行をVBAの中で削除』するのではなくて、マクロ が終わった後から、Excel の一般機能の「検索」により「楽曲タイトル」と書かれている セル を「すべて検索」・選択して、「行全体」を削除されるのが良いかと存じます（この作業自体を マクロ で行なうこともできますが、ご興味があれば、ＶＢＥ で [Find メソッド] の ヘルプ をご覧ください）。

Ｂ】もう１つは、htmlコード を「タブ区切り」・「改行区切り」の文字列に変換して配列に格納し、そのまま ワークシート に展開するものです。
　正規表現により、htmlコード を「改行」・「タブ」に変換したり、削除したりしておりますが、「正規表現」自体の パタン の書き方が素人ですので、無駄な マッチング が多いかと思われます（こちらは別途ご自習ください）。

Sub 配列に格納してから()
　Dim objIE As Object
　Dim RE As Object
　Dim myCh As Variant
　Dim myTbl As Variant
　'dim CB As New DataObject
　Set objIE = CreateObject("InternetExplorer.Application")
　Set RE = CreateObject("VBScript.RegExp")
　With objIE
　　Do
　　　myCh = Application.InputBox("チャンネル番号を入力してください。" _
　　　　& vbNewLine & vbNewLine & "終了するときは キャンセル してください。", _
　　　　"STAR digio", 401, 100, 100, , , 1)
　　　If VarType(myCh) = vbBoolean Then Exit Do
　　　If CInt(myCh) <> myCh Or myCh < 400 Or myCh > 499 Then
　　　　MsgBox "４００～４９９ の整数を入力してください。"
　　　Else
　　　　.Navigate "http://www.stardigio.com/songlists/lists1/" & myCh & ".html"
　　　　Application.Wait (Now + TimeValue("0:00:2"))
　　　　myTbl = objIE.Document.getElementsByName("SongLists")(0).outerHTML
　　　　myTbl = Replace(myTbl, "", "")
　　　　With RE
　　　　　.Global = True
　　　　　.Pattern = "\n.*":　　　　　　　 myTbl = .Replace(myTbl, "")
　　　　　.Pattern = ".*<strong>":　　　　 myTbl = .Replace(myTbl, "")
　　　　　.Pattern = "</strong></h1><p>":　myTbl = .Replace(myTbl, vbCr)
　　　　　.Pattern = "</div>.*?<span>":　　myTbl = .Replace(myTbl, vbCr)
　　　　　.Pattern = "</span>":　　　　　　myTbl = .Replace(myTbl, "")
　　　　　.Pattern = "</h2>.*?<td>":　　　 myTbl = .Replace(myTbl, vbCr)
　　　　　.Pattern = "</td></tr><tr><td>": myTbl = .Replace(myTbl, vbCr)
　　　　　.Pattern = "</td><td>":　　　　　myTbl = .Replace(myTbl, vbTab)
　　　　　.Pattern = "</td>.*?</table>":　 myTbl = .Replace(myTbl, "")
　　　　　.Pattern = "<br>":　　　　　　　 myTbl = .Replace(myTbl, vbCr)
　　　　　.Pattern = "</p>":　　　　　　　 myTbl = .Replace(myTbl, "")
　　　　　.Pattern = "<.*":　　　　　　　　myTbl = .Replace(myTbl, "")
　　　　　.Pattern = "&amp;":　　　　　　　myTbl = .Replace(myTbl, "&")
　　　　　.Pattern = "&nbsp;":　　　　　　 myTbl = .Replace(myTbl, " ")
　　　　End With
　　　　myTbl = Split(myTbl, vbCr)
　　　　Cells(Rows.Count, 1).End(xlUp).Offset(2).Select
　　　　If Selection.Address = "$A$3" Then Range("A1").Select
　　　　Selection.Resize(UBound(myTbl) + 1) = Application.Transpose(myTbl)
　　　End If
　　Loop
　　.Quit
　End With
　Set RE = Nothing
　Set objIE = Nothing
　Columns("A:A").TextToColumns Tab:=True
End Sub

お礼

お手数をおかけします。

まず使い古しのbooksheetについて
あらかじめ関数を記述してあるbooksheetに今回のVBAマクロを追加しwebからのデータをとりこんだ上で、その関数から得られたデータを別の作業に使うことにしています。(取り込みデータはA列、B列、関数記述列はC～F列)
この関数入りのシートにVBAを加えた場合及びなにも書かれていない新規SheetにVBAを記述した場合、いずれでもTESTマクロでは「こんにちわ」までたどり着きました。

次にサンプルコード１による場合は、
差し替えたmyTbl = Left(myTbl, InStr(1, myTbl, "<p class=""caption"">", vbTextCompare) - 1) & "</div>"
のところでNo４と同じメッセージになりました。

サンプルコード２の場合は、数字入力Boxで数字を入れたあと再度数字入力Boxが表示される繰り返しになってしまいました。