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

質問

これは、以前ここで教示していただいた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の部分も変えるとしたらをあわせて、アドバイスをよろしくお願いします。

回答No.1

Wendy02 · ベストアンサー

最初のコードは、
> 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 スタイルでも可能なはずです。

お礼

ありがとうございました。
表示様式を指定して記述すればいいのですね。

myURL = "0062/0062" & Format(Split(myDate, "/")(0) * 1, "00") & _
　　Format(Split(myDate, "/")(1) * 1, "00")

を生かさねばと思って""などでつないでいました。
一応urlの表示はうまくいっている用なのですが、「http://**」は開けません。
インターネットに接続できません」とメッセージが出ちゃうんです。
WEBクリエで呼び出すとちゃんと張り付けることができるんですけどね。

なお、上記VBAのうち後段が抜けていました。
--html"のあと

Columns(1).ClearContents
　With ActiveSheet.QueryTables.Add(Connection:= _
　　"URL;" & Connection_URL, Destination:=Range("A1"))
　　.WebFormatting = xlWebFormattingNone
　　.WebTables = "9"
　　.Refresh BackgroundQuery:=False
　End With
End Sub

これでエクセルに張り付けています。

回答No.12

Wendy02

>WEBデータをとったあと現在でもA列でところどころに文字の色がある部分が生ずるのですが、これはどういう場合が想定されるのか。

クリーム色のパターンのことでしょうか？これは、故意に入れたものですから、
.Cells(i, 1).Resize(, 2).Interior.ColorIndex = 19
という所を外していただければよいのですが、それ以外は、VBAのプログラム上の範疇では考えられません。

もともと、最初に、ClearContents ではなく、Clear ですべてを消去していますから、残ることはありません。こちらでは、かなり試してみましたが、他には、そのような現象は認められません。それとも、別の問題でしょうか。

お礼

０２：００／○
とか6:00
の文字は統一的に茶色になりますが、
ほかにもタイトルのところどころ(A列のみで同じ行でもB列は黒文字）が茶色になったのですが、今いろいろチェックしてみたら、以前の書式設定（上記タイトル部分）が残っているシートの上に呼び出したためのようで、デフォルトフォントを黒文字にしたらなおりました。
行のクリームパターンはわかりやすいのでこれでかまいません。
お騒がせしました。

回答No.11

Wendy02

>ほかの質問の時のフォームと同じになったはずなので、
Like 演算子は、あまり使いたくなかったのですが、今回、やむをえず使いました。
本当は、Option Compare Text モードにすれば、もう少し判別に便利になることもあるのですが、今回は使いませんでした。

>もうひとつ行間をあける目安の「１６：００／○○のパターン」が変わる場合は
>「 Like "##:##?*"」を書き換えることになりますか?

その通りですが、VBAは、他の言語から比較すると表現力が落ちる分、一回で判定しないで、二つに分けて判定するとか、方法はいくつかあります。

だいたい、Like 演算子は、思った以上に使い勝手が悪いです。

>urlに変化があったときはyyyy-mm-ddの書式を直せばいいのですね。このyyyyはリアル日付で年を呼び込んでいるのでしょうか。

日付に関しては、システムに任せています。特別なURLなら、書式を書き換えれば良いです。ちなこに、"yyyy-MM-dd"　とMMを大文字で書く理由は、他の言語でそうやらないと行けないだけで、VBAではどちらでも良い書き方です。

>またチャンネル部分が不要のときは、
完全に不要なら削除すればよいのですが、エラー回避のつもりでしたから、使う可能性があるなら、回避するコードを設けたほうがよいと思います。

　Dim sChan As Variant　'←Long型を、Variant 型に直す

　sChan = Application.InputBox("チャンネル選択", "チャンネル選択", Type:=2)
　If VarType(sChan) = vbBoolean Then Exit Sub
　If sChan > 0 Then
　　strURL = baseURL & myDate & "&ch=" & CStr(sChan)
　Else
　　strURL = baseURL & myDate
　End If

なお、こういうものは、慣れですから、やっていればすぐに覚えられます。
今回のものもそうですが、ソースを文字化けなく取れれば半分は成功したものと同じです。

お礼

まだ色々教えてもらいたい部分はあるのですが、範囲が広がってしまうので、今回は最後にもうひとつだけ教えてください
ANo8の補正の件についてこれは修正可能かどうか。
WEBデータをとったあと現在でもA列でところどころに文字の色がある部分が生ずるのですが、これはどういう場合が想定されるのか。

回答No.10

Wendy02

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を流用して集計作業の方を試したら、これはだめでした。フォームが同じになったのにどうしてうまくゆかないのか、やはり素人考えでの流用はなかなかむつかしいですね。
とりあえず今回は希望する作業まで進むことができ感謝しています。

応用としてもしurlに変化があったときはyyyy-mm-ddの書式を直せばいいのですね。このyyyyはリアル日付で年を呼び込んでいるのでしょうか。たとえば
2010年のものをとりたいときはyyyyを文字列にしてしまえばいいですか？
またチャンネル部分が不要のときは、
「Dim sChan As Long～違うようです。", vbExclamation: Exit Sub」と
strURL = のところの「 & "&ch=" & CStr(sChan)」を削除すればいいですか？
もうひとつ行間をあける目安の「１６：００／○○のパターン」が変わる場合は
「 Like "##:##?*"」を書き換えることになりますか?

セル削除
私も素人的に
Columns("A:A").SpecialCells(xlCellTypeBlanks).Offset(11).ClearContents
を12にしたり、14にしたりして何行か繰り返す記述をしていたのですが、とびとびだとやはり同じ理屈になってしまうのですね。連続の方は行を並べずに済むことができました。

回答No.9

Wendy02

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

>今回は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列目から入れることも出来ますし、レイアウトも、同時に処理してしまいます。一週間、連続取得するとか、そういう方法も可能かと思います。

お礼

ありがとうございました。
作業をしているうちに気がついたのですが
行挿入について依頼が正確でなかったかもしれません。

作成していただいたコードはA列B列の呼び込みデータについて
空白行を挿入していただいていますが、
たぶんA列B列のみ「行移動」処理をされているようで
結果的にほかの列にある関数（M列、L列等）のA,Bを引用しているセルが変化してしまいました。
挿入すれば当然引用セルは変化しますが、行全体を変化させる必要があったわけです。
※ただし、これは前回までの検証により記述しています。

16行目の関数（呼び出すシートのL列～T列に各種関数があらかじめ入れてある。例はN列）
=IF(K16="A","■6",IF(L16="","",+B16))

今回の処理(A16,B16の前に１行挿入）をするとA16,B16のみが変化
=IF(K15="A","■6",IF(L15="","",+B15))
挿入行（=IF(K16="A","■6",IF(L16="","",+B17))
=IF(K17="A","■6",IF(L17="","",+B18))

希望としては
ワークシートの行挿入(16の前に行全体の挿入)をすると
(今回３行にする)

=IF(K15="A","■6",IF(L15="","",+B15))
（挿入行）算式なし
（挿入行）算式なし
（挿入行）算式なし
=IF(K19="A","■6",IF(L19="","",+B19))（全体が変化）

という方法にしたかったのです。
この方法が可能かどうかはわかりませんが、とりあえずお尋ねさせていただきました。
わがままをいってすみません。

ついでにもうひとつアドバ゛イスをお願いします。
次のコードは単独セルの消去ですが、複数のときの表記方法を教えてください
例(１)L列～P列の連続の場合、
例(2)L列,N列,P列のようにとびとびの場合

'Ａ列が「空白」の場合、L列のセルを クリア
Columns("A:A").SpecialCells(xlCellTypeBlanks).Offset(11).ClearContents

回答No.8

Wendy02

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

お礼

毎回ながらご丁寧な回答をありがとうございます。
早速要望のコードを作ってくださり、目的どおりの結果を得ることができました。
ただ、実はちょっといいにくいことですが、前回の質問（補正）を入力した直後に、気がついたのですが、挿入したいのが１行でなく３行だったんです。
申し訳ないですが、もし若干の修正ですむのならよろしくお願いします。大幅改造になるならこのままでけっこうです。

なお、投稿制限の件、以前に削除理由はよくわかりませんが、私自身も体験したことがあったので、その後はかなり神経質になりながら投稿しています。
たしかに今回の例題のように検証するには実際のurlがあった方が回答される方も回答しやすいと思ってはいるので遠回しにしながら書いていたのですが。
内容にもよるのかもしれませんが、helpから自己判断するにはちょっとむつかしいです。

今回は12日に「違反基準に該当するので修正します」という通知を受けました。
No4(1/12)の記述によりあとからわかったことですが、たぶんWendy02様の要請を受けてでの判断かと思います。

補足

それから、日付入力の際、デフォルトで当日の日付がハイライトされていますが、これをほかの日付にしようとすると=$A$1というふうに表示されます。これをいったん消去して1/18と入力すれば別にかまわないのですが、もしかしたらどこかのバグかもしれません。

回答No.7

Wendy02

#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

お礼

No5のコードでGETしたデータのところどころに文字色の異なるものがあって不思議に思っていましたが、なにかのエラーを意味するものだったんですね。
今回のWith ActiveSheet以下はコードの後ろの方にもあって最初はそっちを直してしまいました。
数回後に気がついて、今度は、色文字が途中の段落（時間）以外はすべて黒になりました。
No6のMsgBoxの修正もご指示どおりにしました。
これでほぼ問題なくデータが取れるようになりました。
ありがとうございました。

補足

すみません。ひとつだけ追加で教えてください。取得したデータについて
１６：００／○○のパターン
で始まる行の直前に空白行を１行挿入する
ということが現在のVBAの中で同時処理（追記）することは可能でしょうか？

（Ch123のデータ）
"１６：００","○○"はその都度異なるが"＊＊：＊＊／"（全角）は統一パターン。
(ほかに17:00という行があるがこちらは半角で該当せず)
お手数をおかけします。

回答No.6

Wendy02

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

お礼

OKWEBは無関係のリンク先を記述すると回答自体も消去されるケースがあり当方もその部分はアスタリスクを使っていたのですが、No26のときにurlをうっかり回答者がそのままコード中に記載してしまったものが残っているもので、今回、解析用にご案内したのですが、内容については、このあと色々変化しているためあまり参考にならないかもしれません。
いずれにしても、前回の内容に及ぶのは今回の質問の趣旨に反するかもしれないのでこれ以上触れるないことにしようと思います。せっかくご提示いただいたコードは参考までに自分なりに勉強しつつ解読してみたいと思います。

回答No.5

Wendy02

'前回の続き
　　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"">&nbsp;", 1)
　　　　n = InStr(m, ar(i), "&nbsp;]", 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のような応用力はありません。ソースから切り分けのコードを探し、そこから、文字を取り出す方法です。慣れれば、難しくはありません。

回答No.4

Wendy02

最初に、返事が遅くなりましたことと、今回は、私の勘違いで、ご迷惑をおかけしたことをお詫びいたします。私が、ヘルプを読んでいなかったことが原因で、取消不能だということが分かりました。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
　'次に続く

お礼

体調お悪い最中にも関わらず大変長文なVBAを作っていただきありがとうございました。
最初はやはりエラーが出てしまったので、「.status」を外してみたところばっちりとうまくゆきました。
しかも今回の優れ物はタイトルとアーティスト名が別のセルに分離されたことです。前回までのだと、ワークシートの中で@find関数などを使って分離していました。これならこのあと作成するデータシートの作成にあたって大幅に関連の関数の使用が省略できそうです。ありがとうございました。
コードをじっくり見ても残念ながら素人の小生には難読ばかりで手に負えませんが、そのまま張り付けられれば理解できていなくてもデータが取れるので助かります。
分離にあたって関数を使うと"["を見つけてそこからうしろを別のセルにする訳ですが、応用として前回時の別のURL(No26)のも最小限の修正でこれが使えないかなと思い、この"["が"／"（全角のスラッシュ）だったらどこを直すのかとコードを眺めましたがそれらしきものが見つかりません。
前回のurlのデータの場合は"／"と"＜"で仕切られています。
URLは多分Const baseURL のurlと書式のyyyy-MM-ddを直せばいいのかなと思っています。

gooの短縮アドレスは入力したあと、よく読んだら時間で消失するような内容でなかったので、困ったなと思っていましたが、サポートの方で消してもらえてよかったです。（時間ごとにアクセス数をカウントしているようでした）

今回は貴重な時間をとらせてしまい申し訳なく思っています。
ほんとうにありがとうございました。

回答No.3

Wendy02

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

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

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

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

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

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

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

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

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

お礼

お手数をおかけします。
コードについては色々な方法があると思うので、目的のデータが取れればいいので、従来のコードは無視していただいてけっこうです。
rrMenu の部分は私もcomboがいいかなと思って前回も提案しましたが、今回も109に相当する部分はそれを使いたいと思っています。
内容は123,108,109,110,201,202,204,205からの選択になり、123をデフォルトにしたいと思っています。
日にちは入力のほうがよさそうですが、comboのほうが適していればそれでもかまいません。
ただ、デフォルト表示はリアル日付（その日の日付）がやりやすいです。
元サイトは日付もコンボになっていますが、1-31までが長すぎるのと月末から翌月１日に移るのにいつもめんどうに感じています。

よろしくお願いいたします。