エクセルVBAでWEBデータを取り込む

Question

これは、以前ここで教示していただいたWEBからデータを取り出すVBAの一部です。
日付を入力し、その都度呼び出すWEBページを指定するものです。

－－－－－－－－－－－－－－
myDate = InputBox("オープンする日付を「月／日」のように入力してください。", _
　　"日付の入力", Format(Date, "m/d"))
　myURL = "0062/0062" & Format(Split(myDate, "/")(0) * 1, "00") & _
　　Format(Split(myDate, "/")(1) * 1, "00")

Connection_URL = "http://***/" & myURL & ".html"

－－－－－－－－－－－－－－－－－
これは日付の当てはめにより(1/10の場合)
http://***/0062/00620110.htmlとなるようです。

そこで今回新たに指定したいurlは
http://***/guid/?datest=2011-01-10&ch=109

というものです。この中の-01-10の部分を日付指定により可変としたいのですが
ハイフンがはさまるため上記のVBAを変える必要があるようです。

VBAは初心者のため、元記述を色々書き換えて見たのですがうまくゆきません。
なお、chの部分も変えるとしたらをあわせて、アドバイスをよろしくお願いします。

Wendy02 · Accepted Answer

最初のコードは、
> http://***/0062/00620110.htmlとなるようです。
とするなら、以下になるのではありませんか？ただし、CDate(myDate)というのは、荒っぽい書き方です。

Sub Tes1()
myDate = InputBox("オープンする日付を「月／日」のように入力してください。", "日付の入力", Format(Date, "m/d"))
'本来は、エラー処理をここでする
myURL = "0062/0062" & Format(CDate(myDate), "MMdd")
Connection_URL = " http://***/" & myURL & ".html"
End Sub

> http://***/guid/?datest=2011-01-10&ch=109
109というのは何か分かりませんが、他が、定数なら、以下のようになるはずです。
こちらは、最低限のエラー処理はされています。

Sub Tes2()
Dim myDate As Variant
Const T As String = "109"
myDate = Application.InputBox("オープンする日付を「月／日」のように入力してください。", "日付の入力", Format(Date, "m/d"), Type:=2)
If IsDate(myDate) = False Then Exit Sub
Connection_URL = " http://***/guid/?datest=" & Format(myDate, "yyyy-MM-dd") & "&ch=" & T & ".html"
End Sub

それから、「オープンする日付を「月／日」のように入力してください。」でなくても、yyyy/mm/dd スタイルでも可能なはずです。

Wendy02 · Answer

>一応urlの表示はうまくいっている用なのですが、「 http://**」は開けません。
>インターネットに接続できません」とメッセージが出ちゃうんです。

たぶん、URLが、間違っているには違いないとは思います。
http://***/guid/?datest=2011-01-09&ch=109.html
例えば、貼りつけた後に、自動的に別のコードに変わっているとか、確認してください。

たぶん、どこかの放送の番組表のようですが、こちらでは、今のところ、調べようがありません。自己解決を望みますが、試せれば、こちらでチェックします。

お勧めしませんが、Google の短縮URLを使えば、後で消えてしまいますから、それを使ってもよいと思います。（たぶん、クレームがついた時には、もうURLは役に立たなくなっています。）

Google URL Shortener 
http://goo.gl/
そこで生成されたを貼り付けてもよいです。2時間から、1日、1週間、ひと月、また恒久的なものがあります。
教えて!goo のURL http://goo.gl/qz5H7 (11/02/09 まで有効）

なお、#1のお礼欄で書かれたマクロに関しては、はっきりと明言できませんが、こういうスタイルにしたほうがよいです。

　 ActiveSheet.QueryTables(1).Delete
　ActiveSheet.Range("A1").CurrentRegion.ClearContents
　With ActiveSheet.QueryTables.Add(Connection:= _
　　"URL;" & Connection_URL, Destination:=Range("A1"))
　　.WebFormatting = xlWebFormattingNone
　　.WebTables = "9"
　　.Refresh BackgroundQuery:=False
End With

#6129006 昨年の8月のご質問をひと通りざっと読みましたが、ずいぶん長く続いたようで、今回の流れの一部は、そこからのようです。そのスレのNo.29は同意しますが、私は、あまり質問者さんのレベルには斟酌を加えずに、フリーで許される範囲でコードを書きます。しかし私は、せいぜい数回程度の返事で、最近は元気はありません。特に、こちらのカテゴリでは、トラブルが多発したせいで、あまり書きません。

Wendy02 · Answer

今回の直接のエラーの原因は、「.Refresh BackgroundQuery:=False」の部分のはずです。私が、ちょっと洒落たことをしようとしたのが原因です。

しかし、それでエラーが返らなくても、QueryTables　のVBAでは、サイトに訪れた人の情報を与えないので、取れないことがあります。

それと、良く分かりませんが、文字コードが単純ではないようです。教えて!goo などは、構造はものすごく複雑ですが、文字コードは単純です。目的の所は、Webサイトの構造自体は単純ですから、取得自体は、何ら問題ありません。

それで、今までのコードは、前回もちょっと書いたと思いますが、ほとんど定数以外は参考にはしません。

今回は、UserForm にまとめると良いと思います。
>※arrMenu = Array…は不要なものです。

もし使うなら、本来、これは、UserForm上のComboBox 　などを利用すると良いと思います。そこに、CommandButtonでアクセスするようにして、もう一つのComboBox を設けて、日付の範囲を予め作ってしまってもよいのではないかと思います。

InputBox をあれこれいじってみましたが、マウスだけで入力も出来ません・InputBox は使いづらいです。

> .WebTables = "9"
私もここが分かりません。Webクエリを記録マクロで取っても、それが出てきませんでした。
一覧のリストが取れればそれで良いような気がします。

しばらくお待ちください。一応、変更は可能ですが、こちらで、一旦レイアウトは決めされていただきます。

Wendy02 · Answer

最初に、返事が遅くなりましたことと、今回は、私の勘違いで、ご迷惑をおかけしたことをお詫びいたします。私が、ヘルプを読んでいなかったことが原因で、取消不能だということが分かりました。Google IDを持つ人が、Google Shorter をクリックした回数を調べるために、時間や日付があることでした。そこで、すぐに、こちらの運営側に、訂正をしてただくようにお願いしまた。

また、10日から、高い熱を出して、こちらの書き込み出来なくなってしまいました。今回は、全力をあげて、対処させていただくことで、お詫びに返させていただきます。

'//標準モジュールに貼りつけてください。
Sub GetGlobalObject()
　Dim objHTTP As Object
　Dim httpLog As String
　Dim ar As Variant
　Dim ret As VbMsgBoxResult
　Dim i As Long, j As Long, y As Long
　Dim iDate As Variant, myDate As Variant
　Dim strURL As String
　Dim sChan As Long
　sChan = 118 'チャンネル
　'チャンネルのチェック
　Select Case sChan
　　Case 101 To 126, 200 To 224
　　Case Else: MsgBox "チャンネルが違うようです。", vbExclamation: Exit Sub
　End Select
　
　Const baseURL As String = "http://****************/guid/?datest="
　myDate = Application.InputBox("オープンする日付を「月／日」のように入力してください。", "日付の入力", Format(Date, "m/d"))
　If Not IsDate(myDate) Then MsgBox "正しい日付を入力してください。", vbExclamation
　If VarType(myDate) = vbBoolean Then Exit Sub
　myDate = Format$(myDate, "yyyy-MM-dd")
　strURL = baseURL & myDate & "&ch=" & CStr(sChan)
　
　If Application.CountA(Columns("A:B")) > 0 Then
　　ret = MsgBox("この下に続けますか、前のデータを削除しますか？", vbQuestion + vbYesNoCancel)
　　If ret = vbYes Then
　　　ActiveSheet.Columns("A:B").Clear
　　ElseIf ret = vbCancel Then
　　　Exit Sub
　　End If
　End If
　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　objHTTP.Open "GET", strURL
　'objHTTP.SetRequestHeader "User-Agent", "Mozilla/5.1 (Windows; U; Windows NT 5.0; en-JA; rv:1.9.2.13)"
　objHTTP.Send
　If objHTTP.status = 200 Then
　　httpLog = objHTTP.ResponseBody
　　httpLog = StrConv(httpLog, vbUnicode)
　　With ActiveSheet
　　　y = .Cells(Rows.Count, 1).End(xlUp).Row
　　　If .Cells(y, 1).Value = "" Then
　　　　.Cells(y, 1).Value = myDate
　　　Else
　　　　.Cells(y + 1, 1).Value = myDate
　　　End If
　　End With
　　ar = Split(httpLog, "class=""guid", , 1)
　　If UBound(ar) < 2 Then MsgBox "現在のURLではログが取れていません。", vbCritical: Exit Sub
　'次に続く

Wendy02 · Answer

　　'前回の続き

　　For i = 1 To UBound(ar)
　　　CutandPaste (ar(i))
　　Next
　Else
　　MsgBox "Err " & .status, vbCritica
　　'もしエラーが発生するようでしたら、objHTTP.SetRequestHeaderのコメントブロックを
　　'外してください。
　　Exit Sub
　End If

　With ActiveSheet
　　For i = y + 1 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　If InStr(1, .Cells(i, 1).Text, ":", 1) > 0 Or _
　　　　InStr(1, .Cells(i - 1, 1).Text, ":", 1) > 0 Then
　　　　i = i + 1
　　　ElseIf InStr(1, .Cells(i - 1, 1).Text, ":", 1) = 0 And _
　　　　.Cells(i - 1, 1).Interior.ColorIndex = xlNone Then
　　　　.Cells(i, 1).Resize(, 2).Interior.ColorIndex = 19
　　　End If
　　Next
　　.Columns("A:B").AutoFit
　　.Range("A1").CurrentRegion.HorizontalAlignment = xlLeft
　　Application.Goto .Cells(y, 1), True
　End With
　Set objHTTP = Nothing
End Sub

Function CutandPaste(sLine As Variant)
　Dim TimeTable As Variant
　Dim i As Long, j As Long, m As Long, k As Long, n As Long, y As Long
　Dim ar As Variant, s() As String, a() As String
　i = InStr(1, sLine, "h3"">", 1)
　If i > 0 Then
　　j = InStr(1, sLine, "</h", 1)
　　TimeTable = Mid(sLine, i + 4, j - i - 4)
　　ar = Split(sLine, "</span></li>", , 1)
　　ReDim s(UBound(ar), 0)
　　ReDim a(UBound(ar), 0)
　　For i = 0 To UBound(ar)
　　　j = InStr(1, ar(i), "=""song"">", 1)
　　　If j > 0 Then
　　　　k = InStr(j + 8, ar(i), "</span>", 1)
　　　　s(i, 0) = Mid(ar(i), j + 8, k - j - 8)
　　　　m = InStr(1, ar(i), "=""artist"">", 1)
　　　　n = InStr(m, ar(i), "]", 1)
　　　　a(i, 0) = Mid(ar(i), m + 15 + 8, n - m - 23)
　　　End If
　　Next
　End If
　If UBound(s) > 0 Then
　　With ActiveSheet
　　　 y = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
　　　.Cells(y, 1).Value = TimeTable
　　　.Cells(y, 1).Font.Bold = True: .Cells(y, 1).Font.ColorIndex = 9
　　　.Cells(y + 1, 1).Resize(UBound(s)).Value = s
　　　.Cells(y + 1, 2).Resize(UBound(s)).Value = a
　　End With
　End If
End Function

しばらく試してみてください。マクロは、118になっていますが、109など、ご希望のチェンネルを手動入力してください。今回は、手入力なので、エラーチェックを入れました。QuaryTableのような応用力はありません。ソースから切り分けのコードを探し、そこから、文字を取り出す方法です。慣れれば、難しくはありません。

Wendy02 · Answer

MsgBox "Err " & .status, vbCritical
　　　　↓
MsgBox "Err " & objHTTP.status, vbCritical
としてください。このエラーが出たと言って、その状態(status)を掲示板で聞いても回答する人は少ないし、解決しないとは思いますが、通常、相手のサーバーエラーだと思ってよいです。「HTTP ステータスコード」で、検索してみてください。解決策は、しばらく、時間を空けてアクセスするか、'ObjTTPのコメントブロックを外します。

>httpLog = StrConv(httpLog, vbUnicode)

この行の後に、httpLog は、テキストですから、ここから、切り分けの部分を探します。ただ、Debug.Print ですと、完全に取れないことがあります。今回は、Mid関数で切り分けてしまいました。その分、読みにくいところがあります。

今回のマクロは、他のサイトでは応用できません。サイト専用です。もし、使うなら、新たな組み立てが必要です。正規表現を使えば楽なると思います。しかし、Webサイトでは、きちんとしたものは出ていません。

>前回時の別のURL(No26)のも最小限の修正でこれが使えないかなと思い、
もし今のスタイルと同じにするなら、サイトのソースが必要です。今回の場合は、ResponseBodyでとっていますが、ややこしいのは、文字コードが何種類もあるということです。しかし、ResponseBodyでないこともあります。これをDecode するのは、JavaScriptやADODBなどの文字コードの知識が必要です。私自身、まだ、勉強中です。

大事なことは、そのサイトの構造を捉えてください。
ここのサイトがややこしいのは、画像などは、別のサイトのリンクをされていることで、二重に取得しない見れない時があります。

>前回時の別のURL(No26)
私が書くとこういうスタイルになります。実際のURLが分かりませんと、解析できません。本来は、ComboBox を付けるとよいです。ComboBox は、最初のインデックス　0は、空白にします。また、数字は、1.THE CLASSIC,2.THE JAZZ　というような、1,2 が不要です。
今回は、Input関数を使いましたが、本来は、使ってはいけないというのが、暗黙のルールです。それは、非選択（Cancel)の方法が、古い関数をつかなくてはならなくなります。

一部省略しています。
Sub Test1()
Dim ret
Dim mnNames
Dim mnNos
Dim myUrl As String
Dim sUrl As String
Dim i
Dim cnURL As String
Dim myDate 
Const baseURL As String = "http://www.musicbird.jp/program/"
Const MNNO As String = "70, 80, 32, 62, 101, 102, 90, 120, 40, 22, 31"
Const MNNAME As String = "1.THE CLASSIC,2.THE JAZZ,3.SWING EASY,4.歌謡＆演歌,5.ROCK"
mnNames = Split(MNNAME, ",")
mnNos = Split(MNNO, ",")
ret = InputBox(Join(mnNames, vbCrLf), "メニューの選択", 1)
If Val(ret) < 1 Or Val(ret) > (UBound(mnNames) + 1) Or StrPtr(ret) = vbBoolean Then Exit Sub
i = mnNos(Val(ret) - 1)
myUrl = Format(Val(i), "0000")
myDate = Application.InputBox("オープンする日付を「月／日」のように入力してください。", "日付の入力", Format(Date, "m/d"), Type:=2)
If IsDate(myDate) = False Or VarType(myDate) = vbBoolean Then Exit Sub
myDate = Format(myDate, "MMdd")
sUrl = myUrl & "/" & myUrl & myDate
cnURL = baseURL & sUrl & ".html"
Debug.Print cnURL
End Sub

Wendy02 · Answer

#5 のコードは、以下に変えたほうがよいです。色分けで、上手く行かないところが出ています。

With ActiveSheet
　　For i = y + 3 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　 If .Cells(i, 1).Text Like "*#:##*" Or _
　　　　 .Cells(i - 1, 1).Text Like "*#:##*" Then
　　　　 i = i + 1
　　　 ElseIf Not .Cells(i - 1).Text Like "*#:##*" And _
　　　　.Cells(i - 1, 1).Interior.ColorIndex = xlNone Then
　　　　.Cells(i, 1).Resize(, 2).Interior.ColorIndex = 19
　　 End If
　　Next
　　.Columns("A:B").AutoFit
　　.Range("A1").CurrentRegion.HorizontalAlignment = xlLeft
　　Application.Goto .Cells(y, 1), True
　End With
　Set objHTTP = Nothing
End Sub

Wendy02 · Answer

#7 の補足の件
やはり、Like 演算子は表現力が今ひとつのようです。

>"１６：００","○○"はその都度異なるが…
どうやら、その都度異なる、というのが事実のようですね。今のところは書式で追いかけいますが、統一性が取れないと2列目で判定をさせたほうがよいかもしれません。この部分は様子見です。

>１６：００／○○のパターン
>で始まる行の直前に空白行を１行挿入する
今の範疇で押さえたいと思いましたが、基本的には違う流れのようですのでコードを加えました。
後ろEnd Sub から、With ActiveSheet を探してください。

With ActiveSheet　
　　For i = y + 3 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　 If VarType(.Cells(i, 1).Value) = vbDouble And _
　　　　 .Cells(i, 1).Text Like "?#:##" Then
　　　　 i = i + 1
　　　 ElseIf StrConv(.Cells(i, 1).Text, vbNarrow) Like "*#:##*" Or _
　　　　 StrConv(.Cells(i - 1, 1).Text, vbNarrow) Like "*#:##*" Then
　　　　 i = i + 1
　　　 ElseIf Not StrConv(.Cells(i - 1).Text, vbNarrow) Like "*#:##*" And _
　　　　.Cells(i - 1, 1).Interior.ColorIndex = xlNone Then
　　　　.Cells(i, 1).Resize(, 2).Interior.ColorIndex = 19
　　 End If
　　Next
　　Application.ScreenUpdating = False
　　For j = .Cells(Rows.Count, 1).End(xlUp).Row To y + 1 Step -1
　　 If StrConv(.Cells(j, 1).Text, vbNarrow) Like "##:##?*" Then
　　　　 .Cells(j, 1).Resize(, 2).Insert
　　　　 .Cells(j, 1).Resize(, 2).Interior.ColorIndex = xlNone
　　 End If
　　Next j
　　Application.ScreenUpdating = True
　　.Columns("A:B").AutoFit
　　.Range("A1", .Cells(i, 1)).HorizontalAlignment = xlLeft
　　Application.Goto .Cells(y, 1), True
　End With
　Set objHTTP = Nothing
End Sub

p.s. 質問とは離れますが、誤解を恐れずに、今後のためにも書かせていただきます。
#6のお礼の中で、
>OKWEBは無関係のリンク先を記述すると回答自体も消去されるケースがあり…

今回は、削除されたり訂正されるような内容ではありません。オンデマンドのはずです。No.2を書いた後に、GoogleのHelpを読み、Help掲示板で同じような問題で解決していないことが分かりました。そこで、9日の深夜に「教えて!goo」を通してOkWave側に、メールで、noro6857さんに問い合わせるようにお願いしました。それがこちらの経緯です。もし、それ以前のOkWaveのメールなら、私の思い違いです。

なお、ここのカテゴリで調べてみましたが、最近、OkWaveのプライバシーの考え方が変わったようです。人には、それぞれの事情があります。この話は別の場所で書きましたが、赤の他人には関係ないことも、本人の身近かな人にとっては、ちょっとしたことで、本人が浮き彫りになって、今後のお仕事などに余計な障害になる可能性があります。

ここの質問者の中には、自分の持っているサイト（例：ジオシティーズ）や匿名のレンタル・ダウンロードサイトにアップロードして、不要になれば消してしまう人もいます。今回、他者の10/8/14の質問で、まだ残ってることを確認してまいす。

今回は、URLがないと、文字コードの組み合わせからデコードするのは不可能に近いです。だから、イレギュラーな手段も、現在は質問者には許されている行為だと思います。また、いろんな抜け道は、お互いに探してみる必要がありそうです。

Wendy02 · Answer

返事が遅くなってすみません。

>今回は12日に「違反基準に該当するので修正します」という通知を受けました。
それは、大変失礼しました。私の依頼メールの趣旨(11/01/10　深夜)は、あくまでも、私のミスのためによるものだから、ご本人に、問い合わせしてほしいというものです。ここのログは読んだ上のこととは思いますが、あまり考えて文章を書いている様子はありません。今回のことは、誤解を与えたことになってしまったかもしれません。

>以前に削除理由はよくわかりませんが
多くは、閲覧者の会員の連絡によるオンデマンドです。サーバーの何かで検索しているものもありますが、引っかかるものは、もう滅多にありません。運営側は連絡を受けて、緊急のものと、そうでないものを区分けして、緊急のものから手を付けているようです。今回のものは、こちらの要請で緊急性があったと信じます。通常は、削除されることはありません。

さて、プログラムのほうは、また再び、下のEnd Sub から書き換えてください。まだ、集中力が戻ってこないで、ミスがあるかもしれません。

なお、
>For j = .Cells(Rows.Count, 1).End(xlUp).Row To y + 3 Step -1
　y + 3　のy は、最初の行で、通常は　1ですから、行の挿入の検査は、4行目からということになります。もし、それ以下の行も入れる場合は、+3 を外して、y+1 にもどしてください。でも、y は削除しないでください。

Application.ScreenUpdating = False
　　For j = .Cells(Rows.Count, 1).End(xlUp).Row To y + 3 Step -1
　　 If StrConv(.Cells(j, 1).Text, vbNarrow) Like "##:##?*" Then
　　　　 .Cells(j, 1).Resize(3, 2).Insert Shift:=xlShiftDown
　　　　 .Cells(j, 1).Resize(3, 2).Interior.ColorIndex = xlNone
　　 End If
　　Next j
　　Application.ScreenUpdating = True
　　.Columns("A:B").AutoFit
　　.Range("A1", .Cells(i, 1)).HorizontalAlignment = xlLeft
　　Application.Goto .Cells(y, 1), True
　End With
　Set objHTTP = Nothing
End Sub

今回のものは、QueryTable でも、なんとかなりますが、たぶん、スピードが違うはずです。
何と言っても、下に続けることも出来れば、3列目から入れることも出来ますし、レイアウトも、同時に処理してしまいます。一週間、連続取得するとか、そういう方法も可能かと思います。

Wendy02 · Answer

Application.ScreenUpdating = False
　　For j = .Cells(Rows.Count, 1).End(xlUp).Row To y + 3 Step -1
　　 If StrConv(.Cells(j, 1).Text, vbNarrow) Like "##:##?*" Then
　　　　 .Cells(j, 1).Resize(3).EntireRow.Insert Shift:=xlShiftDown '←ここを書き換え
　　　　 .Cells(j, 1).Resize(3, 2).Interior.ColorIndex = xlNone
　　 End If
　　Next j
　　Application.ScreenUpdating = True
　　.Columns("A:B").AutoFit
　　.Range("A1", .Cells(i, 1)).HorizontalAlignment = xlLeft
　　Application.Goto .Cells(y, 1), True
　End With
　Set objHTTP = Nothing
End Sub

このように書き換えてあげれば、良いはずです。

ところで、
>=IF(K16="A","■6",IF(L16="","",+B16))
事情が分かりませんので、今は、ご要望の挿入という形で提示していますが、この程度の範囲は、マクロで処理してもよいような気がします。また、そのほうが楽かと思います。
-----

> 'Ａ列が「空白」の場合、L列のセルを クリア
>　Columns("A:A").SpecialCells(xlCellTypeBlanks).Offset(11).ClearContents
>例(１)L列～P列の連続の場合、
>例(2)L列,N列,P列のようにとびとびの場合

On Error Resume Next
Set r = Range("A:A").SpecialCells(xlCellTypeBlanks)
　If Not r Is Nothing Then
　 Intersect(r.EntireRow, Columns("L")).ClearContents　'とびとびの場合
　 Intersect(r.EntireRow, Columns("N")).ClearContents
　 Intersect(r.EntireRow, Columns("P")).ClearContents
　 'Intersect(r.EntireRow, Columns("L:P")).ClearContents '連続の場合
　End If
On Error GoTo 0

エクセルVBAでWEBデータを取り込む

最初のコードは、

>一応urlの表示はうまくいっている用なのですが、「

今回の直接のエラーの原因は、「.Refresh BackgroundQuery:=False」の部分のはずです。

最初に、返事が遅くなりましたことと、今回は、私の勘違いで、ご迷惑をおかけしたことをお詫びいたします。

'前回の続き

MsgBox "Err " & .status, vbCritical

#5 のコードは、以下に変えたほうがよいです。

この回答への補足

#7 の補足の件

この回答への補足

返事が遅くなってすみません。

Application.ScreenUpdating = False

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

　　'前回の続き

　　Application.ScreenUpdating = False