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

質問

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

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

回答No.26

DOUGLAS_ · ベストアンサー

＞「図が大きすぎます。入らない部分は切り捨てられます。」
＞VBAA25実行時(A23でも)なぜかときどき張り付けられない
　同じ理由から来る エラー ではないかと存じますので、とりあえず、下記でお試しになった結果をお知らせください。

ActiveSheet.Paste
の前に
While Application.ClipboardFormats(1): DoEvents: Wend
を
Application.CutCopyMode = False
の前に
Range("A1").Copy
を挿入してみてください。

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

＞※ちあきなおみの「注」のL列消去は今までやっていた方法なので
＞今回の改善でゼロ表示するようになり楽になりました。
　了解しました。

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

＞前に、読込み後下記VBAを実行している旨記述しましたが
＞ANo25VBAの最後にこれをを勝手に加えてしまって同時処理
＞しているのですが、かまわないでしょうか。（ダブりますか?）

　ん？　これにつきましては、「ANo.24」に書きましたように、

＞なお、お示しの２行の マクロ を実行されるときは、・・・
から
＞「Sub for_spacediva2」から、以上の２点を訂正した・・・
までの操作をなさってください。

お礼

Range("A1").Copy
を挿入してみてください。

一応出なくなりました。
「一応」というのは、修正後最初１回出たのですが、その後は出ていないので、しばらく様子を見てみます。ありがとうございました。

補足

今回もご丁寧にたくさんのアドバイスをいただきありがとうございました。おかげさまでこれからも毎日活用できそうです。
また機会がありましたらよろしくお願いいたします。

回答No.25

DOUGLAS_

＞※訂正バージョンは、私は勝手にSub for_spacediva
＞1A23のように回答日日付を入れていました。
＞了解しました。
　それでしたら、それで結構です。

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

＞日付ですが、入力画面がハイライトされているので
＞7/31の1だけを治そうと思い矢印キーでハイライトを消すと
＞入力画面が$B$1のようになってしまうため、ハイライトのまま
＞いきなり7/30と上書きするようになっているのでしょうか
＞q6129006ANo26の日付入力は矢印キーで１文字だけ修正できましたが。

　そうですね。
myDate = Application.InputBox("放送日を「月／日」の書式で指定してください。", _
　　"放送日の選択", Format(Date, "m/d"))
If myDate = 0 Then Exit Sub
を
On Error Resume Next
myDate = InputBox("放送日を「月／日」の書式で指定してください。", _
　"放送日の選択", Format(Date, "m/d"))
If myDate = 0 Then Exit Sub
On Error GoTo 0
に差し替えてください。

　実は、q6435241 の方で、「ANo.6」の回答者さんが、
＞今回は、Input関数を使いましたが、本来は、使ってはいけない
＞というのが、暗黙のルールです。それは、非選択（Cancel)の方法が、
＞古い関数をつかなくてはならなくなります。
とお書きでしたので、（私には、お書きの意味が解らないのですが）私らしくなく [InputBox メソッド] を使いました。

　[InputBox 関数] は [キャンセル] されたときも、ユーザー が「空欄」で応答したときも、ともに「長さ 0 の文字列 ("") 」を返すので、その区別が付かない、というのが理由なのでしょうか？？？

　なお、上記は完全な エラー処理 はしておりません。
　無効な日付が入った場合は エラー になりますが、noro6857 さんだけがお使いになるということを前提にして、コード を書いておりますので、それを踏まえてお使いくださるものとしています。

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

＞＞=IF(L5="","",{ANo.22 の元々の式})
＞＞とのことですが、「L5=""」になることはありませんので、無用な処理です。
＞L列の数字を手動で消すことがあるのです。
　そういうことでしたら、大変失礼いたしました。
　とても緻密な作業をしていらっしゃるようで、お話しを伺っただけで、私なんかは気が遠くなりそうです。
<(_ _)>

＞ちあきなおみの「注」もそのままだと、
＞曲順が付されるためL列の消去で空欄にしています。
　ん？　まぁ、これはそれでも構いませんが、Ｄ列 に補助列を設けて「曲順が付」すように計算式を立てたときに、Ｂ列が空欄の行には連番が付されないようにしてありますよん。

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

＞>画面からはみ出して入力欄
＞※これは１箇所だけ存在しますが、同じパターンの入力
＞なので見えないまま入力していました。
＞ご指摘の部分は修正しておきます。
　了解しました。

＞＞集計は「：」を先頭にした行
＞＞とお書きなのは、Ｍ列～Ｑ列に「■」が並ぶ行のことでよろしいですね。
＞※そのとおりです。
　了解しました。

＞「関数式の入っているBook」は テンプレート として保存
＞※テンプレートで保存していて、呼び込みに使用した場合
＞その都度新しいファイル名で保存しています。
＞続けて使用すると削除列が次の読込みに影響してしまうためです。
　了解しました。

＞１）「Sub Group_for_each_Title_Line」を実行すると
＞※こちらの方はおかげさまで今までも問題なく作業ができています。
　了解しました。

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

　また、何かありましたらご連絡ください。

お礼

Bookを別名保存してエクセルを終了させるときにこんなメッセージが出ます
「図が大きすぎます。入らない部分は切り捨てられます。」（OK)

VBAA25実行時(A23でも)なぜかときどき張り付けられないとのメッセージで止まることがあります。
ActiveSheet.Paste（デバッグ）
理由もなくsheet1/2のA列B列の空欄を1～600行くらいまで再デリートしてやってみたときにスムースにできることもありました。
一般的にスムースにできるときとできないときがあり、この状況は判断できません。

※ちあきなおみの「注」のL列消去は今までやっていた方法なので
今回の改善でゼロ表示するようになり楽になりました。ありがとうございました。

前に、読込み後下記VBAを実行している旨記述しましたが
'Ａ列が「空白」の行の全体を クリア
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
'Ａ列が「数値」の行の Ｌ列 を クリア
Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Offset(, 11).ClearContents

ANo25VBAの最後にこれをを勝手に加えてしまって同時処理しているのですが、かまわないでしょうか。
（ダブりますか?）

回答No.24

DOUGLAS_

＞なお、前回２行式を書いたのは以下の列に同じように
＞記入している旨を念のために書いたものです
　了解いたしました。

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

＞ご質問がこれ以外に入ってましたら
＞見落としているかもしれないのでよろしくお願いします。

＞とりあえず意とするようになりました。
とういことは、
＞http://www.spacediva.jp/guid/?datest=&ch=123&datest=2011-07-30
＞の場合に
＞「※ちあきなおみ 特集・・・」というような注釈行が連続したときに
＞意図しない計算結果になっているのではないかと、
＞勝手に推測して、その不具合を勝手に是正
した点はＯＫということでよろしいのですね。

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

　次に「Sub for_spacediva1」についてですが、先ず、最初に「ANo.23」の「Sub for_spacediva1 」は マクロ の 訂正バージョン が分からなくなりますので、末尾の数字を「2」に変えて「Sub for_spacediva2」にしておいてください。
　続いて、更にこれから訂正するものを「Sub for_spacediva3」ということにしておきましょう。

＞ （ただ日付の入力フォームが入っていないのですが）
「Sub for_spacediva2」の
myDate = Date
を
myDate = Application.InputBox("放送日を「月／日」の書式で指定してください。", _
　"放送日の選択", Format(Date, "m/d"))
に差し替えてください。

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

＞ANo23によりSheet2に取り込んだデータをSheet1にCopyしたあと、
＞次のVBAを実行して関数式を空白セルにする作業を行っています。
　これは、これで問題ないかと存じます。
　「関数式の入っているBook」は テンプレート として保存しておられて、作業が済んだら、そのまま保存せずに終了していらっしゃるのでしょうから。。。

　なお、お示しの２行の マクロ を実行されるときは、Ｄ列（補助列）の式が壊れてしまいますので、「Sub for_spacediva2」の最後の
Sheets("Sheet1").Select
の後に
　Range(Range("D5"), Range("D5").End(xlDown)).Select
　Selection.Copy
　Selection.PasteSpecial xlPasteValues
　Application.CutCopyMode = False
　Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
　Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Offset(, 11).ClearContents
を追加してお使いください。

　「Sub for_spacediva2」から、以上の２点を訂正したものを「Sub for_spacediva3」ということにしておきます。

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

＞K5
＞=IF(L5="","",{ANo.22 の元々の式})
とのことですが、「L5=""」になることはありませんので、無用な処理です。

　また、
＞M5
＞=IF(K5="","",{ANo.22 の元々の式})
とのことですが、「K5=""」になるのは、「B5=""」のときで、これにつきましては、{ANo.22 の元々の式} でその処理をしておりますので、こちらも無用な処理です。

　ということで、
＞K5とM5はご指示のものを一部修正しました。
につきましては、元に戻していただいた方がよいかと存じます。

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

　q6129006 の方は約１年前の回答ですが、我ながらよくこんな式を書いたものだと、ちょっと恥ずかしくなりました。

N5:=IF(K5="A","■6",IF(K5="","",+B5))
O5:=IF(K5="A","■4",IF(K5="","",+F5&"-"&K5&"-"&Q5))
P5:=IF(K5="A","■3",IF(K5="","",+Q5&"-"&F5&"-"&K5))
につきましては式中の「+」は不要です。

Q5:=IF(K5="A","■2",IF(K5="","",TRIM(M5)&"("&N5&")"))
　M5 を TRIM する必要はないかも知れませんが、この式はこれでよいかと存じます。

R5:=IF(K5="A","MB"&F5&"="&A5,IF(K5="","",FIXED(L5,0,TRUE)&"."&Q5))
は、
R5:=IF(K5="A","MB" & F5 & "=" & A5,IF(K5="","",L5 & "." & Q5))
ですね。

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

＞集計のVBAは長くなるので省略しますが
＞以前いただいたq6129006
＞ANo27/28(No30により一部修正）
＞により実行しています。
　今、試してみたところ、１つのブロックの行数がたまたま大きいときに、ファイル名 選択の ダイアログ が画面からはみ出して入力欄が見えなくなるようですので、「Sub Group_for_each_Title_Line」の
If IsArray(DataChecker) Then _
の前に
ReDim Preserve DataChecker(30)
を挿入してください。

＞集計は「：」を先頭にした行
とお書きなのは、Ｍ列～Ｑ列に「■」が並ぶ行のことでよろしいですね。

＞のM～R列までを１グループ（１グループ２０行程度）とし
＞R(20行。各１列めは■になる）P Q O M N と縦に並べます。
＞終わったら次のグループを同じように整列。

１）「Sub Group_for_each_Title_Line」を実行すると、
２）「D:\hoge\」フォルダ に、ブロックごとに、ユーザー が手動で付けた名前の「txt ファイル」を作成し、
３）マクロ を開始した カーソル 位置の直上の ブロック から下方向に向かって、順次、
４）ブロックごとに「strCols = "RPQOMN"」のところで設定した列の順番に、データ を縦に並べて「txt ファイル」に保存します。

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

　以上、「Sub for_spacediva3」または「Sub Group_for_each_Title_Line」につきまして不具合がございましたらお知らせください。

お礼

＞勝手に推測して、その不具合を勝手に是正
した点はＯＫということでよろしいのですね
※了解です。

※訂正バージョンは、私は勝手にSub for_spacediva1A23のように回答日日付を入れていました。
了解しました。

日付ですが、入力画面がハイライトされているので7/31の1だけを治そうと思い矢印キーでハイライトを消すと入力画面が$B$1のようになってしまうため、ハイライトのままいきなり7/30と上書きするようになっているのでしょうか
q6129006ANo26の日付入力は矢印キーで１文字だけ修正できましたが。

＞=IF(L5="","",{ANo.22 の元々の式})
とのことですが、「L5=""」になることはありませんので、無用な処理です。

※これは前回もくどくどとご説明してしまったのですが、L列の数字を手動で消すことがあるのです。
というのは各グループの最終行が演奏のみの場合と、歌唱とがあって
演奏のみの場合は空白行にするため、個別に判断し、L列を消すことでM以降を関数を残したままの空白行にしています。
（関数行を消してしまうとグループく区切りになってしまうため途中に存在するものは式のみ残しています）
これは残念ながらルールが取り込めないため手動になってしまいます。
ちあきなおみの「注」もそのままだと、曲順が付されるためL列の消去で空欄にしています。

>画面からはみ出して入力欄
※これは１箇所だけ存在しますが、同じパターンの入力なので見えないまま入力していました。
ご指摘の部分は修正しておきます。

＞集計は「：」を先頭にした行
とお書きなのは、Ｍ列～Ｑ列に「■」が並ぶ行のことでよろしいですね。
※そのとおりです。

　「関数式の入っているBook」は テンプレート として保存しておられて、
※テンプレートで保存していて、呼び込みに使用した場合、その都度新しいファイル名で保存しています。
続けて使用すると削除列が次の読込みに影響してしまうためです。

１）「Sub Group_for_each_Title_Line」を実行すると
※こちらの方はおかげさまで今までも問題なく作業ができています。

回答No.23

DOUGLAS_

不具合がありましたので、下記を訂正してください。

　最初の
Selection.End(xlUp).Select
を
If Mid(Selection.Value, 3, 1) <> "：" Then
　Selection.End(xlUp).Select
End If
に差し替えてください。

　いろいろと変更になりましたので、念のため、全文を掲載しておきます。

Option Explicit

Sub for_spacediva1()
　Dim RE As Object
　Dim objHTTP As Object
　Dim myDate As Date
　Dim myCh As Long
　Dim strURL As String
　Dim myTbl As String
　Dim CB As New DataObject
　Application.ScreenUpdating = False
　Set RE = CreateObject("VBScript.RegExp")
　Set objHTTP = CreateObject("MSXML2.XMLHTTP")
　myDate = Date
　If myDate = 0 Then Exit Sub
　myCh = 123
　With objHTTP
　　strURL = "http://www.spacediva.jp/guid/?datest=" & Replace(myDate, "/", "-") & "&ch=" & myCh
　　.Open "GET", strURL, False
　　.Send
　　myTbl = StrConv(.ResponseBody, vbUnicode, 1041)
　End With
　myTbl = Mid(myTbl, InStr(myTbl, "<h3"))
　myTbl = Format(myDate, "yyyy/m/d") & vbCr & Left(myTbl, InStrRev(myTbl, "<!-- end songlist") - 1)

　With RE　'%S=<、%T=空白行
　　.Global = True
　　myTbl = Replace(myTbl, "&nbsp;", "")
　　myTbl = Replace(myTbl, "<br />", "")
　　.Pattern = "<.*name?.*>"
　　myTbl = .Replace(myTbl, "%T")
　　.Pattern = "<(.?)h3.*?>"
　　myTbl = .Replace(myTbl, "%S$1h3>")
　　.Pattern = "<(.?)ul>"
　　myTbl = .Replace(myTbl, "%S$1table>")
　　.Pattern = "<span.*?>"
　　myTbl = .Replace(myTbl, "")
　　.Pattern = "<.*cnorm.*?>"
　　myTbl = .Replace(myTbl, "%Str>%Std>")
　　.Pattern = "<.*cblue.*?>"
　　myTbl = .Replace(myTbl, "%Str bgcolor=""#dfdfe9"">%Std>")
　　myTbl = Replace(myTbl, "</span>[", "%S/td>%Std>")
　　myTbl = Replace(myTbl, "]</span></li>", "%S/td>%S/tr>")
　　.Pattern = "<.*?>"
　　myTbl = .Replace(myTbl, "")
　　myTbl = Replace(myTbl, "%S", "<")
　　myTbl = Replace(myTbl, "%T", "<h3>空白行</h3>" & vbCr)
　End With
　myTbl = "<style>h3 {color:#932;}</style>" & myTbl
　With CB
　　.SetText myTbl
　　.PutInClipboard
　　.GetFromClipboard
　End With
　Sheets("Sheet2").Select
　Range("A1").Select
　ActiveSheet.Paste
　Rows(1).Insert
　Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　Cells.Replace "空白行", ""
　Range("A" & Rows.Count).End(xlUp).Select
　Do
　　If Mid(Selection.Value, 3, 1) <> "：" Then
　　　Selection.End(xlUp).Select
　　End If
　　If Selection.Address = "$A$1" Then
　　　Range("A2:A4").EntireRow.Insert
　　　Exit Do
　　End If
　　Selection.Resize(2).EntireRow.Insert
　　Selection.End(xlUp).Select
　Loop
　Columns("A:B").AutoFit
　Columns(1).HorizontalAlignment = xlLeft
　Range("A1").Select
　Columns("A:B").Copy Sheets("Sheet1").Range("A1")
　Columns("A:B").Delete
　Sheets("Sheet1").Select
　Set objHTTP = Nothing
　Set RE = Nothing
　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございました。
再度お聞きしたいことができてしまいました。新Qで投稿します。

回答No.22

DOUGLAS_

＞これにA20のVBAを実行すると、
＞関数の一部がこわれてしまい
　そうですね。関数が入っているであろうことは全く無視した ＶＢＡ の コード です。
　こういうことが、実際の noro6857 さんの目の前にある ワークシート での ニーズ になります。

＞行の削除挿入の影響かと思う
　仰るとおりです。
　ステップ イン デバッグ するとすぐ判明しますが、
Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
の行で、ほとんど関数入りの セル が「#REF!」になってしまいます。

＞対応は可能でしょうか。
　これは、noro6857 さんがご自身で、その答えを書いていらっしゃいますが、
＞関数式の入っているBookのsheet2（関数なしのsheet)で
＞VBAを実行した後にそのデータを関数式の入っている
＞sheet1にCopyするとエラーが出てない
でよいかと存じます（変更箇所が少なくて済む）。

　先ず、最初の
Range("A1").Select
の前に
Sheets("Sheet2").Select
を挿入し、
Set objHTTP = Nothing
の前に、
Columns("A:B").Copy Sheets("Sheet1").Range("A1")
Columns("A:B").Delete
Sheets("Sheet1").Select
を挿入します。

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

＞関数はたぶんもっと適したものがあるかもしれません
　私的には、「自動修復されるためここでは割愛」された列に入っている計算式と、最終的に、どの列の データ を縦並びに置き換えるのかというところまでお示しいただけば、上記の「sheet1にCopyする」操作もせずに、すべて マクロ によって「データ を縦並びに置き換える」ところまでできるかとは存じます。
　しかし、余り、弄くり回して、訳が分からなくなりそうな気配もありますので、今回は、お示しいただいた列の計算式だけが有効になる方向で考えてみたいと存じます。

　お示しの計算式は、以前のご質問のときに私がお答えしたものかも知れませんが、また、「適したもの」という表現が正しいかどうか判りませんが、例えば、
＞D1（A1の日付を６けたに文字列にコード化。110728）
は
D1:=TEXT(A1,"yymmdd")
でいいかと存じます。

　他の列に入っている計算式につきましては、とりあえず、式そのものが冗長にならない方向で、考えてみました（E4・E5、F4・F5、K4・K5、L4・L5、M4・M5 に入っている式は、同じ構成のようですが、どうして２行分お示しになられたのでしょうか？）。
　場合によっては、お望みの計算結果と異なることもあろうかと存じますので、「123Ch 7/30 のデータ」
http://www.spacediva.jp/guid/?datest=&ch=123&datest=2011-07-30
の場合に、「どの行の値」が「どのように」おかしいということを ピンポイント でお示しください。
　例えば、「※ちあきなおみ 特集・・・」というような注釈行が連続したときに、意図しない計算結果になっているのではないかと、勝手に推測して、その不具合を勝手に是正しております。

　４行目のみ書きます。

＞E4（０：００の時間部分を文字列にして次の２：００になるまで
＞各行に割り当てる０：００は0に、２：００のときは2に）
E4:=IF(MID(A4,3,1)="：",LEFT(A4,2)*1,E3)

＞F4（D1でコード化した日付にEの時間を２桁にして
＞連結し各行に割り当て。11072800のように）
F4:=$D$1 & TEXT(E4,"00")

＞K4(L列による連番を２けたの文字列にする。ただしL列が空欄の
＞ときは、空白に、A列に■がある行は「Ａ」表示にする）
K4:=IF(MID(A4,3,1)="：","A",IF(B4="","",TEXT(L4,"00")))

＞L4(連番をつける。ただし上１行、上２行があいているときは
＞連続させ、それ以上の空きがある場合は1から再連番）
　補助列（例えば、Ｄ列とする）を設け
D4:=IF(MID(A4,3,1)="：",ROW(),D3)
という式を入れてください。
L4:=IF(B4="",0,MAX(INDIRECT("L" & D3 & ":L" & ROW()-1))+1)

M4:=IF(MID(A4,3,1)="：","■5",IF(B4="","",A4))

　以上の式を４行目に入れて、これを５行目以下に オートフィル してください。

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

＞エクセルというのは
＞（くしざし、結合みたいな感じで）ような技ってあるのでしょうか。
　「串刺し」という機能はあります（正式名称は存じません）
http://www.google.co.jp/search?sourceid=ie7&q=%E4%B8%B2%E5%88%BA%E3%81%97+excel&rls=com.microsoft:ja:IE-Address&ie=UTF-8&oe=UTF-8&rlz=1I7MOCJ&redir_esc=&ei=BIw0TsbuH6KKmQXl6JDxCg
が、お尋ねの件とは用途が異なると存じます（私は串刺し機能を使ったことがありませんので、詳しく存じません）。

＞せっかく一気に生成されるデータを
＞単にほかにCOPYするだけのためのものでは惜しい気がして
いらっしゃるのは、Excel様 に対して、とてもお優しい気配りかと存じますが、
＞なにか活用できればと思
われるのでしたら、
＞D列以降に式だけを書いたbook1に
＞ 式のないBook2（今回のスタデジのようにデータのみを生成するものでA列B列）を重ねて
＞Book2の中にデータを得る
というような ブック を跨ぐ計算式は立てられない方が無難かと存じます。

＞せっかく一気に生成されるデータ
は、マクロ が瞬時にしてくれていることですので、個々の「データ」の単位で、ブック を跨いで作業をするのではなくて、作業に特化した計算式の入っている ブック に、「一気に生成されるデータ」の入っている シート 自体を コピー して、そちらの ブック で作業を簡素化されることをお薦めいたします。

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

＞UserFormの開放という設定を行っていますが
＞XMLHTTP用のために行うものでしょうか
　いいえ違います。
　[ANo.4] に書きましたが、本来なら、クリップボード を操作するために「Microsoft Forms 2.0 Object Library」に参照設定しなければならないのですが、通例、この操作は ＶＢＥ から [ツール(T)] - [参照設定(R)...] にて行なうべきはずのものなのに、noro6857 さんの [参照可能なライブラリ ファイル(A)] の中に「Microsoft Forms 2.0 Object Library」がありませんでしたので、その代替策として、[ANo.4] に書いた操作をお知らせいたしました。

　まぁ、
１）ＶＢＥ で [挿入(I)] - [ユーザー フォーム(U)] を クリック し、ユーザーフォーム を追加します。
だけでよいのですが、(１) の操作は、「Microsoft Forms 2.0 Object Library」に参照設定するためだけの操作であって、この件に関しては、別に「ユーザー フォーム」が必要な訳ではありません。
参考ＵＲＬ）http://officetanaka.net/excel/vba/tips/tips20.htm
<上記より引用> DataObjectオブジェクトはMSFormsのメンバです。使用するには、Microsoft Forms 2.0 Object Libraryを参照設定します。または、ブックにUserFormを挿入すると自動的に参照設定されます。<ここまで引用>

　私が、余分な荷物を積むのは嫌いな質ですので、
２）[プロジェクト エクスプローラ]（左側の樹形図）の [VBAProject（Book名）] - [フォーム] - [UserForm1] を 右クリック - [Userform1 の解放(R)...] を クリック します。
３）「解除する前に UserForm1 をエクスポートしますか?」には [いいえ(Y)] を クリック します。
というお節介なことを書いただけです（大意はありません）。

お礼

A20によりSheet2に取り込んだデータをSheet1にCopyしたあと、
次のVBAを実行して関数式を空白セルにする作業を行っています。
とりあえず意とするようになりました。
（ただ日付の入力フォームが入っていないのですが）
--------------------------------------------------------
'Ａ列が「空白」の行の全体を クリア
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents

'Ａ列が「数値」の行の Ｌ列 を クリア
Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Offset(, 11).ClearContents
End Sub

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

各セルの式（EFKLMの関数式はだいぶすっきりしました。なおK5とM5はご指示のものを一部修正しました。K5="","")

D1
=TEXT(A1,"yymmdd")
E5
=IF(MID(A5,3,1)="：",LEFT(A5,2)*1,E4)
F5
=$D$1 & TEXT(E5,"00")
K5
=IF(L5="","",IF(MID(A5,3,1)="：","A",IF(B5="","",TEXT(L5,"00"))))
L5
=IF(B5="",0,MAX(INDIRECT("L" & D4 & ":L" & ROW()-1))+1)
M5
=IF(K5="","",IF(MID(A5,3,1)="：","■5",IF(B5="","",A5)))
N5
=IF(K5="A","■6",IF(K5="","",+B5))
O5
=IF(K5="A","■4",IF(K5="","",+F5&"-"&K5&"-"&Q5))
P5
=IF(K5="A","■3",IF(K5="","",+Q5&"-"&F5&"-"&K5))
Q5
=IF(K5="A","■2",IF(K5="","",TRIM(M5)&"("&N5&")"))
R5
=IF(K5="A","MB"&F5&"="&A5,IF(K5="","",FIXED(L5,0,TRUE)&"."&Q5))

なお、前回２行式を書いたのは以下の列に同じように記入している旨を念のために書いたものです

------------------------
集計のVBAは長くなるので省略しますが
以前いただいたq6129006
ANo27/28(No30により一部修正）
により実行しています。

集計は「：」を先頭にした行のM～R列までを１グループ（１グループ２０行程度）とし
R(20行。各１列めは■になる）
P
Q
O
M
N
と縦に並べます。
終わったら次のグループを同じように整列。

なおご質問がこれ以外に入ってましたら
見落としているかもしれないのでよろしくお願いします。

補足

下記
A20によりSheet2に取り込んだ
というのは今回作っていただいたANo23の誤りです。

回答No.21

DOUGLAS_

＞スタデジ分VBAについて１点
＞A2以下の■を付されたタイトル部分の末尾にスペースが入っていて
＞今まで関数式を残しておいた理由はこれもあったような気がしました。
　この件は「ANo.13」に書きましたが、元から分かっておりました。

＞エクセルの段階でTRIMをかけてスペースをとってしまえ
　これにつきましては、<<< 一番最後 >>> の
Range("A1").Select
の <<< 前 >>> に

Range(Range("C1"), Range("A" & Rows.Count).End(xlUp).Offset(, 3)).Select
Selection.FormulaR1C1 = "=TRIM(RC[-2])"
Selection.Copy
Range("A1").Select
Selection.PasteSpecial xlPasteValues
Columns("C:D").Delete

の６行を挿入してみてください。

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

＞それと別の方作の「VBAで文字化け」があり・・・
＞どうやらサイトそのものに問題があることがわかりました。
　了解しました。前の回答者さんのお目に止まってなければよいですが。。。

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

＞htmlTAGでの代入はわたしもよくテキスト化するときや
＞ほかのhtmlを作成するときによくやりました。
＞これにVBA用語が加わればいいんでしょうね。

　そうですね。私的には、これが html & VBA の醍醐味とまではいかないまでも、いろいろな場面で重宝しています。

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

　なお、明朝より３日ほど、留守をいたしますので、急なご相談は、今の内にどうぞ。

お礼

次の点よろしくお願いします。

A20のVBAについて
次の関数を入れてあるブックにおいて
（なおこれらの関数を引用するほかの列がG～PまであるのですがそちらはE/Lが直れば自動修復されるためここでは割愛）
EFKLMについては、5行目から下、データの呼び込まれる500行くらいまで式はCOPYします

D1（A1の日付を６けたに文字列にコード化。110728）
=RIGHT(YEAR(A1),2)&IF(MONTH(A1)<10,"0"&MONTH(A1),(MONTH(A1)))&IF(DAY(A1)<10,"0"&DAY(A1),(DAY(A1)))

E4（０：００の時間部分を文字列にして次の２：００になるまで各行に割り当てる０：００は0に、２：００のときは2に）
=IF(ISERR(FIXED(VALUE(LEFT(A4,(FIND(":",ASC(A4),1)-1))),0,TRUE)),E3,IF((FIND(":",ASC(A4),1)-1)<2,"0","")&FIXED(VALUE(LEFT(A4,(FIND(":",ASC(A4),1)-1))),0,TRUE))
E5
=IF(ISERR(FIXED(VALUE(LEFT(A5,(FIND(":",ASC(A5),1)-1))),0,TRUE)),E4,IF((FIND(":",ASC(A5),1)-1)<2,"0","")&FIXED(VALUE(LEFT(A5,(FIND(":",ASC(A5),1)-1))),0,TRUE))

F4（D1でコード化した日付にEの時間を２桁にして連結し各行に割り当て。11072800のように）
=$D$1&IF(LEN(E4)=1,"0"&E4,E4)
F5
=$D$1&IF(LEN(E5)=1,"0"&E5,E5)

K4(L列による連番を２けたの文字列にする。ただしL列が空欄のときは、空白に、A列に■がある行は「Ａ」表示にする）
=IF(ISERR((FIND("：",A4,1)-1)),IF(L4=0,"",IF(L4<10,"0"&FIXED(L4,0,TRUE),FIXED(L4,0,TRUE))),"A")
K5
=IF(ISERR((FIND("：",A5,1)-1)),IF(L5=0,"",IF(L5<10,"0"&FIXED(L5,0,TRUE),FIXED(L5,0,TRUE))),"A")

L4(連番をつける。ただし上１行、上２行があいているときは連続させ、それ以上の空きがある場合は1から再連番）
=IF(ISNUMBER(A4),0,IF(A4="",0,IF(ISERR((FIND("：",A4,1))),IF(ISERR(FIND("■",M3)),IF(L2+L3=0,1+L1,IF(L3=0,L2+1,L3+1)),1),0)))
L5
=IF(ISNUMBER(A5),0,IF(A5="",0,IF(ISERR((FIND("：",A5,1))),IF(ISERR(FIND("■",M4)),IF(L3+L4=0,1+L2,IF(L4=0,L3+1,L4+1)),1),0)))

M4
=IF(K4="A","■5",IF(B4="","",IF(L4="","",+A4)))
M5=IF(K5="A","■5",IF(B5="","",IF(L5="","",+A5)))

これにA20のVBAを実行すると、各ブロック０：００(２：００等を含む）のE/Lので始まる行と次の１行の関数の一部がこわれてしまい
下段の関数が関連してすべてエラーになってしまいました。(F及びK列のエラーはE/L引用によるもので実質エラーなし）
各2行めから下はこわれていないのでそれをこわれている部分にCOPYすると表示がなおります。
ちなみにこの関数式の入っているBookのsheet2（関数なしのsheet)でVBAを実行した後にそのデータを関数式の入っているsheet1にCopyするとエラーが出てないため表示状況がわかりやすいかと思います。
（Eの場合、記述式内「E3,E4」の部分が#REF!に、L4の場合は記述式内「M3」以降右の部分が#REF!に）
多分E/Lの引用関連セルを上書きか消去してしまうか、行の削除挿入の影響かと思うのですが、対応は可能でしょうか。
(これとほぼ同内容の呼び込みを行うq6435241のVBAの場合はエラー発生はしなかったのですが）

なお関数はたぶんもっと適したものがあるかもしれませんのであわせてお知恵も。

それからひとつお尋ねですが、
エクセルというのはたとえばD列以降に式だけを書いたbook1に
式のないBook2（今回のスタデジのようにデータのみを生成するものでA列B列）を重ねて
Book2の中にデータを得る（くしざし、結合みたいな感じで）ような技ってあるのでしょうか。
今回のようにせっかく一気に生成されるデータを単にほかにCOPYするだけのためのものでは惜しい気がしてなにか活用できればと思いました。
それと今回UserFormの開放という設定を行っていますが、これは今までのVBAでやったことがなかったものですが、XMLHTTP用のために行うものでしょうか

補足

お留守の間に色々試しておきたいと思いますので、なにかありましたらまたお礼欄に書かせていただきます。よろしくお願いします。

回答No.20

DOUGLAS_

＞最近文字化けが発生することが多いのでやや困っていました。
　これは、「杉山清貴&オメガトライブ」が「杉山清貴&amp;オメガトライブ」になるようなことでしょうか？

＞日付表示については・・・
＞これをA1に入れます。
＞次に３行あけてA5から・・・
＞そのあとも００：００／のような記述・・・
＞全角のみなので1:00のようなものは含まれません。
＞読み込むデータは現時点ではこの記述式を使っている123chのみ
　以上、了解いたしました。

＞これはかつてDOUGLAS_様に作っていただいた・・・
　何だか、耳が痛いような。。。

＞このときのVBAでは・・・
＞今回は途中にある１つのグループのみを想定
　また、作業を進める内に不具合がございましたら、お知らせください。

　以前もこういう意味のことを書きましたが、ＷＥＢページ の内容・構成は日々、変化します。
　昨日作成した ＶＢＡ が、今日には使えなくなる、みたいなこともあり得ます。
　したがって、都度、修正を加えていくのは、当然のことです。

＞ほかのときに活用できると考えました。
＞これを単独で走らせたり、ほかのマクロの中に
＞記述したりけっこう使わせてもらっています。
　ぃゃぁ、とっても前向きな コメント で、苦労が報われますヮ。

＞今回の３行あけもその行の関数式を消去するため使う
　マクロ の中で空白行を挿入するようにしておりますので、関数式は、入っておりません。

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

　さて、本題に入りますが、人に書いてもらうと、何をしているのかさっぱり解らないということにもなりましょうから、操作の内容を箇条書きでお知らせしておきます。

　noro6857 さんは、ホームページ作成 とかも手がけていらっしゃるようですので、htmlタグ の知識につきましては、プロ(並み？)かと存じますから、その点の解説は割愛いたします。

１）htmlタグ を読み込み myTbl に代入します。
２）最初の「<h3」より前を削除します。
３）myTbl の最初に {日付文字列} を挿入し、
　　最後の「<!-- end songlist」以降を削除します。

※これ以後、「%S・%T」は、後から「<・空白行」に置換します。

４）タグ内 の「&nbsp;」(スペース)を削除します。
５）タグ内 の「<br />」を削除します。
　　(４)・(５) ともに不要のようです。
６）「name」を含む タグ を「%T」に置換します。
　　ここがタイトル行になります。
７）「h3」タグ の「<」を「%S」に置換します。
８）「ul」タグ を「table」タグ に変え、「<」を「%S」に置換します。
９）「span」開始タグを削除します。
10）「cnorm」を含む タグ を「%Str>%Std>」に置換します。
11）「cblue」を含む タグ を「%Str bgcolor=""#dfdfe9"">%Std>」に置換します。
　　ここで、セル に色が付くようにしています。
12）「</span>[」を「%S/td>%Std>」に置換します。
13）「]</span></li>」を「%S/td>%S/tr>」に置換します。
14）すべての htmlタグ（"<"と">"で囲まれた文字列）を削除します。
15）「%S」を「<」に置換します。
16）「%T」を「<h3>空白行</h3>{改行コード}」に置換します。
17）myTbl の先頭に「<style>h3 {color:#932;}</style>」を追加します。

18）myTbl を クリップボード に積み込み、A1 に ペースト します。
19）Ａ列 が空白の行を削除します。
20）「空白行」の文字列の入った セル を クリア します。
21）(20) の セル群 について、おのおのの前に３行の空白行ができるように調整します。
22）Ａ・Ｂ列 の列幅を調整します。
23）Ａ列 の書式を左寄せにします。

　以上です。

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

Sub for_spacediva1()
　Dim RE As Object
　Dim objHTTP As Object
　Dim myDate As Date
　Dim myCh As Long
　Dim strURL As String
　Dim myTbl As String
　Dim CB As New DataObject
　Application.ScreenUpdating = False
　Set RE = CreateObject("VBScript.RegExp")
　Set objHTTP = CreateObject("MSXML2.XMLHTTP")
　myDate = Date
　If myDate = 0 Then Exit Sub
　myCh = 123
　With objHTTP
　　strURL = "http://www.spacediva.jp/guid/?datest=" & Replace(myDate, "/", "-") & "&ch=" & myCh
　　.Open "GET", strURL, False
　　.Send
　　myTbl = StrConv(.ResponseBody, vbUnicode, 1041)
　End With
　myTbl = Mid(myTbl, InStr(myTbl, "<h3"))
　myTbl = Format(myDate, "yyyy/m/d") & vbCr & Left(myTbl, InStrRev(myTbl, "<!-- end songlist") - 1)

　With RE　'%S=<、%T=空白行
　　.Global = True
　　myTbl = Replace(myTbl, "&nbsp;", "")
　　myTbl = Replace(myTbl, "<br />", "")
　　.Pattern = "<.*name?.*>"
　　myTbl = .Replace(myTbl, "%T")
　　.Pattern = "<(.?)h3.*?>"
　　myTbl = .Replace(myTbl, "%S$1h3>")
　　.Pattern = "<(.?)ul>"
　　myTbl = .Replace(myTbl, "%S$1table>")
　　.Pattern = "<span.*?>"
　　myTbl = .Replace(myTbl, "")
　　.Pattern = "<.*cnorm.*?>"
　　myTbl = .Replace(myTbl, "%Str>%Std>")
　　.Pattern = "<.*cblue.*?>"
　　myTbl = .Replace(myTbl, "%Str bgcolor=""#dfdfe9"">%Std>")
　　myTbl = Replace(myTbl, "</span>[", "%S/td>%Std>")
　　myTbl = Replace(myTbl, "]</span></li>", "%S/td>%S/tr>")
　　.Pattern = "<.*?>"
　　myTbl = .Replace(myTbl, "")
　　myTbl = Replace(myTbl, "%S", "<")
　　myTbl = Replace(myTbl, "%T", "<h3>空白行</h3>" & vbCr)
　End With
　myTbl = "<style>h3 {color:#932;}</style>" & myTbl
　With CB
　　.SetText myTbl
　　.PutInClipboard
　　.GetFromClipboard
　End With
　Range("A1").Select
　ActiveSheet.Paste
　Rows(1).Insert
　Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　Cells.Replace "空白行", ""
　Range("A" & Rows.Count).End(xlUp).Select
　Do
　　Selection.End(xlUp).Select
　　If Selection.Address = "$A$1" Then
　　　Range("A2:A4").EntireRow.Insert
　　　Exit Do
　　End If
　　Selection.Resize(2).EntireRow.Insert
　　Selection.End(xlUp).Select
　Loop
　Columns("A:B").AutoFit
　Columns(1).HorizontalAlignment = xlLeft
　Range("A1").Select
　Set objHTTP = Nothing
　Set RE = Nothing
　Application.ScreenUpdating = True
End Sub

お礼

スタデジ分VBAについて１点

A2以下の■を付されたタイトル部分の末尾にスペースが入っていて
呼び出されたものをそのままLotusにCOPYすると
■2000年代J-POPヒット曲 が
■2000年代J-POPヒット曲 と表示され
そのソースをテキストに張ると
■2000年代J-POPヒット曲 ￡ ￡になってしまいます。
なんの意味かわかりませんがエクセルの段階でTRIMをかけてスペースをとってしまえばその表示にはなりません。
ついてはVBAの中でTRIMをかけることができるのでしょうか。
今まで関数式を残しておいた理由はこれもあったような気がしました。

それと別の方作の「VBAで文字化け」があり、VBAに問題があるように書いてしまいましたが作者様の名誉を損なうので修正しますが、当方のマクロと相性が悪いのかと思っていました。
しかし今回再度試して見て、当方の勘違いでどうやらサイトそのものに問題があることがわかりました。
今回のGET分でも7/27分123Ch2.00の６番目(遙恋)ヤン・チェンが
SpaceDivaの方は「曲名？」「ヤン・チェン」になっていました。
MusicBirdの方は(遙恋)ヤン・チェンになっています。
この「？」が文字化けと思っていました。
作者様には大変失礼をしました。申し訳ありません。

今回の大作はまだテストしていませんので、後に報告させていただきます。
htmlTAGでの代入はわたしもよくテキスト化するときやほかのhtmlを作成するときによくやりました。これにVBA用語が加わればいいんでしょうね。

回答No.19

DOUGLAS_

＞A1のところは2011/7/21（放送日）と表示したい
　「for_spacediva0」マクロ を実行すると、

A1:B1　109ch　J-POP REFRAIN
A2　　放送日：2011/07/26
A3　　00：00／j-pop refrain

となりましたが、この場合、

A1　　2011/7/21（放送日）

として、

A1:B1　109ch　J-POP REFRAIN

の部分は、２行目に下げ、

A2　　放送日：2011/07/26

の行は削除するという解釈でよろしいでしょうか？

　それと、「07/26」ではなくて、「7/26」のように「0」を入れない形でよろしいのですか？

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

＞００：００／の表示で始まる
セル が見つかった場合（例えば A3）に、その
＞前３行に空欄行を入れ
るとお書きなのは、A1 の前に「空欄行」を入れるということでしょうか？

　ちなみに、今、SPACE DiVA の 101ch ～ 356ch のすべての チャンネル の今日の番組表を読み込んでみましたが、
＞００：００／の表示で始まる
ところがあるのは、101ch ～ 124ch までの チャンネル の、それも、３行目に限定されているようですが。。。

　「００：００／」とお書きなのは、「1:00」とか「2:00」も含めるのでしょうか？

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

＞並べ替えのVBAについて、
＞最初の矩形はD1～G20、次の矩形をD23～G40というふうな場合、
＞カーソルをおいた行からの集計をするとしたらどうなりますでしょうか。

　カーソル を手（マウス）で持って行かれる、という意味でしょうね。
　その場合は、カーソル をおいた セル を「ActiveCell」と言いますので、
Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
となります。

　「矩形ブロック の左上の セル」と書きましたが、「コピー したい範囲の左上隅の セル」と書いた方が良かったでしょうか。

　たとえば、

□Ａ□□□
□□□□□
□Ｂ■■■
□□■■■
□□■■■
□□■■■
□□■■■
□□■■■

というような矩形があった場合、黒い部分だけを転記するのであるのなら、「左上」というのは「Ａの左の□」ではなくて「Ｂの右の■」になります。
　ですから、そこに カーソル を持っていくと、「Ｂの右の■」が「ActiveCell」になります。

お礼

日付表示についてはわたしも「07/26」にすべきかどうか迷ったのですが、
既存の関数式で0を入れない対応をしてしまっているため、2011/7/21でかまいません。
これをA1に入れます。
次に３行あけてA4から００：００／の行を先頭にしたグループ表示をします。
そのあとも００：００／のような記述(「０２：００／」等全角数字とスラッシュ）のところで前３行あけます。
全角のみなので1:00のようなものは含まれません。
なお読み込むデータは現時点ではこの記述式を使っている123chのみです。
（いずれほかのChも必要になるかもしれませんが）
これはかつてDOUGLAS_様に作っていただいた(A30)VBAによるグループ集計に活用するために００：００／単位(「０２：００／」等全角数字とスラッシュを含む）でのブロック形式にするためです。

このときのVBAでは、００：００／のすぐ上の行にカーソルをおいて実行すると、
その下のブロック集計ができるようになっていました。
（自動的にグループ集計が移動するようになっていましたが今回は途中にある１つのグループのみを想定）
このときはM列～R列(6列)のデータを対象にしましたが、今回のD～Gの質問は、この列が6列でない場合の応用を単独VBAで矩形集計のみを教えておいていただけるとほかのときに活用できると考えました。
この場合は図のAの位置またはBより上の空欄行になると思います。集計の先頭セル（Bの右）でもいいかもしれません。

なお、前回の質問の中で
'Ａ列が「空白」の行の全体を クリア
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents

'Ａ列が「数値」の行の Ｌ列 を クリア
Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Offset(, 11).ClearContents
というVBAを教えてくださいましたが、
これを単独で走らせたり、ほかのマクロの中に記述したりけっこう使わせてもらっています。
たぶん今回の３行あけもその行の関数式を消去するため使うことになるかと思います。

補足

下記
「次に３行あけてA4から」は3行あけるとA5からになりますね。

回答No.18

DOUGLAS_

大変お待たせいたしました。
　「前回」の件で随分と手間取りました。

＞並べ替えVBAは開始がD列以外の場合は
＞記述の「D1」を変えればいいいでしょうか。
　そうですね、矩形ブロック の左上の セル を指定してください。

＞列の増減は、このVBAのままで、列のなくなる
＞ところまでは繰り返されるというような感じでしょうか

　この件に付きましては、例で申せば、D1:G1、D1:D20 の間さえ詰まっていれば ＯＫ です。
　E2:G20 の間は空いていても差し支えありません。

＞それとmusicbirdについては・・・
　よく解りました。
　別に回答者にご質問者さんを咎め立てする権利も何もございませんが、ベター または ベスト の方法があればと思っての要らぬお節介でした。

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

　さて、
＞q6435241でいただいたもの
についてですが、ご回答者さんのお示しになった コード を一通り並べて実行してみますと、ワークシート に ツートンカラー の データ が配置されました。

　誠に申し訳ございませんが、q6129006 のときのご要望も忘れてしまいましたし、その時にも書きましたが、人様がお書きになった コード を弄くり回すのは不本意ですので、新規に書いてみました。

　とりあえず、
http://www.spacediva.jp/guid/?datest=2011-07-26&ch=109
の ページ を読み込み、「曲名」と「アーティスト」を別の セル に分けるところまで書いておりますので、追加のご要望をお知らせください。

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

Sub for_spacediva0()
　Dim RE As Object
　Dim objHttp As Object
　Dim myDate As Date
　Dim strURL As String
　Dim myHead As String
　Dim myTbl As String
　Dim CB As New DataObject

　Application.ScreenUpdating = False
　Set RE = CreateObject("VBScript.RegExp")
　Set objHttp = CreateObject("MSXML2.XMLHTTP")
　myDate = Application.InputBox("オープンする日付を「月／日」のように入力してください。", "日付の入力", Format(Date, "m/d"))
　If myDate = 0 Then Exit Sub
　With objHttp
　　strURL = "http://www.spacediva.jp/guid/?datest=" & Replace(myDate, "/", "-") & "&ch=109"
　　.Open "GET", strURL, False
　　.Send
　　myTbl = StrConv(.ResponseBody, vbUnicode, 1041)
　　myHead = Left(myTbl, InStr(myTbl, "</span></p>") - 1)
　　myHead = Mid(myHead, InStr(myHead, "tbold") + 7)
　　myHead = Replace(myHead, "|", vbTab) & vbCr
　　myTbl = Mid(myTbl, InStr(myTbl, "<h3"))
　　myTbl = myHead & "放送日：" & myDate & vbCr & Left(myTbl, InStrRev(myTbl, "<!-- end songlist") - 1)
　　myTbl = Replace(myTbl, "&nbsp;", "")
　　myTbl = Replace(myTbl, "<span class=""artist"">[", vbTab)
　　myTbl = Replace(myTbl, "]</span>", "")
　　With RE
　　　.Global = True
　　　.Pattern = "<.*?>"
　　　myTbl = .Replace(myTbl, "")
　　　.Pattern = "\n\s+"
　　　myTbl = .Replace(myTbl, vbCr)
　　End With
　　With CB
　　　.SetText myTbl
　　　.PutInClipboard
　　　.GetFromClipboard
　　End With
　　Range("A1").Select
　　ActiveSheet.Paste
　End With
　Set objHttp = Nothing
　Set RE = Nothing
　Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　Columns("A:B").Columns.AutoFit
　Range("A1").Select
　Application.ScreenUpdating = True
　MsgBox "終わったゎ"
End Sub

お礼

新たなVBAを作ってくださりありがとうございます。
単純に要望のみを書きます。
A1のところは2011/7/21（放送日）と表示したい
００：００／の表示で始まるA列の前３行に空欄行を入れたい。
（これはブロック単位に列の並べ替えを行うための区切り行として判定させるため）
このくらいでだいじょうぶかと思います。
よろしくお願いします。

並べ替えのVBAについて、
最初の矩形はD1～G20、次の矩形をD23～G40というふうな場合、カーソルをおいた行からの集計をするとしたらどうなりますでしょうか。

回答No.17

DOUGLAS_

＞従来のhttp://www.musicbird.jp/はアナログ終了に伴い、
＞７月末で終了するため
＞別の上記サイトの局の同内容を利用することになる

とのことですが、
http://www.musicbird.jp/channels/index.html
に、

＞※2011年7月をもってPCM放送サービスを終了させていただきます。
＞詳しくはこちらをご覧ください。

とあり、「こちら」には、

＞【2011年8月以降のプログラムガイド誌について】 (2011年5月更新)
＞永年ご購読いただきましたプログラムガイド誌につきまして、
＞2011年7月号をもってやむを得ず廃刊とさせていただきます。
＞今後は、当社ホームページのソングリスト、
＞又は2011年8月から新たに発行となる「ソングリスト」をご活用いただきたく
＞お願い申し上げます。 「ソングリスト」の詳細はこちら

　更に、「詳細はこちら」には、

＞今後は、当社ホームページのソングリスト、又は下記
＞「ソングリスト」をご活用いただきたくお願い申し上げます。

と書かれていますね。

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

　ということは、
＞別の上記サイトの局の同内容を利用する
のではなくて、
＞今後は、当社ホームページのソングリスト
を
＞ご活用いただきたくお願い申し上げます。

　その「ホームページのソングリスト」には リンク が貼ってありまして、それを クリック すると、
http://www.musicbird.jp/land/songlist.html
の ページ が開きます。

　そこに、

＞【曲目リスト＜ソングリスト＞のご利用方法】
＞STEP1.ご希望のチャンネルをクリック
＞下記一覧から、ご希望のチャンネルを選び、クリックします。
＞STEP2. チャンネルページが開きます
＞別ウィンドウでチャンネルのページが開きます。
＞右上の「ソングリスト」をクリックします。
＞STEP3. 本日の放送内容が表示されます
＞別ウィンドウが開き、本日の放送内容が表示されます。
＞右上の「日付」の欄を変更し「GO」をクリックすると、
＞ご覧になりたい日にちの放送内容が表示されます。

と書かれてあって、そのまま操作してみると、

STEP1.「9ch-2 歌謡 ＆ 演歌」を クリック します。
STEP2.右上の「ソングリスト」を クリック します。
STEP3.下記 ＵＲＬ の ページ が開きました。
http://www.musicbird.jp/program/0062/00620726.html

　ですから、終了するのは「PCM放送サービス」であって、「ソングリスト」ではないようですので、ＶＢＡ はそのまま使えるかと存じますねぇ（お宝鑑定団/中島誠之助さん風）。
　これからも大事になすってください。　（笑

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

　さて、それでも、まぁ、せっかく コード を コピペ していただきましたので、一応「別の上記サイト」でも動くようには作り替えてみましたが、まぁ、実行していただければお分かりになるかとは存じますが、ワークシート に展開された データ の フォーマット が、musicbird とは随分異なるので、その分、事後の処理が大変かと存じます（これ以降は、noro6857 さんのご趣味の問題です）。

　なお、spacediva の方は、クエリテーブル が ページ全体 になっておりますので、ご存じとは存じますが、読み込み自体にも随分時間がかかります。

Sub Using_Web_query_0726()
　Dim arrMenu As Variant
　Dim myDate As String
　Dim myURL As String
　Dim Connection_URL As String

　arrMenu = Array(70, 80, 32, 62, 101, 102, 90, 120, 40, 22, 31)
　myDate = InputBox("オープンする日付を「月／日」のように入力してください。", _
　"日付の入力", Format(Date, "m/d"))
　myURL = Replace(CDate(myDate), "/", "-")

　Connection_URL = "http://www.spacediva.jp/guid/?datest=" & myURL & "&ch=123"
　Columns(1).ClearContents
　With ActiveSheet.QueryTables.Add(Connection:= _
　　"URL;" & Connection_URL, Destination:=Range("A1"))
　　.WebFormatting = xlWebFormattingNone
　　.WebSelectionType = xlEntirePage
　　.Refresh BackgroundQuery:=False
　End With

　'クエリテーブル の前後の余分な行を削除
　Range(Range("A1"), Range("A:A").Find("放送日").Offset(-1)).EntireRow.Delete
　Range(Range("A:A").Find("楽曲名*アーティスト名"), _
　　Range("A" & Rows.Count).End(xlUp)).EntireRow.Delete
　Range("A1").Value = Format(CDate(myDate), "mm月dd日(aaa)")
　Range("A1").Select
End Sub

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

＞q6435241でいただいたもの・・・・・・・
＞アドレス変更後にも使いたくてお願いする次第

　よく意味が把握出来ませんが、後でじっくり見てみます。

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

＞縦１列にD1～D20～E1～E20～F1～F20～G1～G20に並べ変えてテキストを生成したい。

　必ず Ｄ列 から始まり、Ｄ列 から右下方向に 空きセル はないという条件でしたら、

Dim myRng As Range
Dim i As Long
Sheets("データシート").Select
Set myRng = Range(Range("D1"), Range("D1").End(xlDown).End(xlToRight))
Sheets("貼り付け").Select
For i = 1 To myRng.Columns.Count
　Range("A1").Offset((myRng.Rows.Count) * (i - 1)).Resize(myRng.Rows.Count) _
　　= myRng.Columns(i).Value
Next

というようなことで達成できます。

お礼

どうもありがとうございました。
日付差し替えのVBAは読込みがうまくゆきましたので、前回のテキスト展開VBAにあわせた関数を組み換えて、うまく結合するようにトライしてみたいと思います。
並べ替えVBAは開始がD列以外の場合は記述の「D1」を変えればいいいでしょうか。また列の増減は、このVBAのままで、列のなくなるところまでは繰り返されるというような感じでしょうか
こちらはまだテストしていませんが応用の範囲で勉強させていただきます。

それとmusicbirdについては言い訳をする訳ではありませんが、リスナーとして今後の方針を問い合わせた際、当面はhttp://www.musicbird.jp/program/のリストは存続するかもしれないが、いずれspacedivaに統一するということでしたので、放送終了後それほど遠くない時期にmusicbirdソングリストも廃止されるものと考えています。現在は移行手続きをしているmusicbirdリスナーのためにmusicbirdソングリストがリンクされているようです。
もちろんこのまま今までのソングリストが継続されれば助かるのですが。

なお今回作っていただいた本来の質問のVBAにつきましたは、週末に新しいデータが公開されますので、それによる作業が終わってからもし不都合が生ずる場合は再度お尋ねしたいと思いますので、しばらく締め切りをしないでおきたいと思いますのでよろしくお願いします。

回答No.16

DOUGLAS_

（＾凹＾）ガハハ　　ミス連発どすゎ　　(´ヘ｀;)

＞１行目の「■110725SD401」はSDは固定ですが
＞そのあとは該当Chの数字にしたい
myTbl(0) = "■" & myTbl(0) & "SD401"
の行を
myTbl(0) = "■" & myTbl(0) & "SD" & myList(myCh)
に差し替えてください。

＞110725についてはサイト元データの２行目の放送開始日が入るように
　これにつきましては、既にそのように コード を書いております。

＞411Chの一部が取り込まれている
ActiveWorkbook.Close
の後に、
Cells.Delete
を挿入してください。

　ただし、ワークシート には、何も（「計算式」も）無いことが前提です。

＞不要な「開始時間」の行が残ってしまいました。
Columns("A:A").Replace "楽曲タイトル", ""
の後に、
Columns("A:A").Replace "開始時間*", ""
を挿入してください。

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

　さて、後回しのご質問について。。。

＞後に別の方に別のVBAを教えていただきましたが、
とお書きなのは、
http://okwave.jp/qa/q6435241.html
のことですね？

　この記事をざっと拝見しましたが、
＞これは日付の当てはめにより(1/10の場合)
＞http://***/0062/00620110.htmlとなるようです。
＞そこで今回新たに指定したいurlは
＞http://***/guid/?datest=2011-01-10&ch=109
＞というものです。
というご質問で、回答者さんから回答をいただいていらっしゃいますね。

　ところが、
＞前回の分について、サイト名（記述式）が変更になってしまったので
＞ここで修正の方法をお願いしてよろしいでしょうか。
とお書きですが、先ほど、例の サイト に行ってみますと、
http://***/0062/00620110.html
という形式の ＵＲＬ になって（戻って）いましたよ？

　私は、
http://***/guid/?datest=2011-01-10&ch=109
という形式に変わったことは存じませんが、少なくとも、今は、「私との前のご質問（q6129006）」の時の ＵＲＬ に戻った訳ですから、そのときお示しした、コード で行けるかと存じます。

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

＞最近文字化けが発生することが多いのでやや困っていました。
　これは、「q6129006」の時の コード でお試しいただいているのに。。。という意味でしょうか？

　お尋ねになっている点が少しぼんやりしています。
　ステップ イン デバッグ などをなさって、どのご質問の、どの コード の、どの時点に問題がありそうなのかお知らせいただかないと、ちょっと答えようもございません。

＞前回以来せっかくご指導いただく機会ができたので
　この スレッド の続きになっても構いません（ホントは規約違反かも。。。）ので、どうぞ、ご遠慮なくお尋ねください。
　ただし、時間はかかるかも知れません。

お礼

こんどはうまくゆきました。お手数をかけました。これで当分楽しめそうです。

さて、下のVBAは前回のものを現在利用しているものです。
このうちサイトが次のように変わるため、日付の挿入位置が変わってしまいました。
http://www.spacediva.jp/guid/?datest=2011-07-22&ch=123

末尾の123は変化ありません。（日付部分のみをその都度変更になります）

従来のhttp://www.musicbird.jp/はアナログ終了に伴い、７月末で終了するため別の上記サイトの局の同内容を利用することになるものです
このためフォームはほぼ同じなのでアドレスだけ変更すればそのまま使えそうだと思っています。

---------------
Sub Using_Web_query30A()
Dim arrMenu As Variant
Dim myDate As String
Dim myURL As String
Dim Connection_URL As String

arrMenu = Array(70, 80, 32, 62, 101, 102, 90, 120, 40, 22, 31)
myDate = InputBox("オープンする日付を「月／日」のように入力してください。", _
"日付の入力", Format(Date, "m/d"))
myURL = "0062/0062" & Format(Split(myDate, "/")(0) * 1, "00") & _
Format(Split(myDate, "/")(1) * 1, "00")

Connection_URL = "http://www.musicbird.jp/program/" & myURL & ".html"
Columns(1).ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Connection_URL, Destination:=Range("A1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.Refresh BackgroundQuery:=False
End With

'Ａ列が「空白」の行の全体を クリア
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents

'Ａ列が「数値」の行の Ｌ列 を クリア
Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Offset(, 11).ClearContents

'上記の２行で、Ｍ列～Ｒ列内には エラー はなくなりますよね。
End Sub
-------------------

それとお頼みついでに、この際、頻繁に使う作業があるので、ここの部分だけのVBAを教えていただけますか（上記とは別のものです）
これは前回の質問でも類似のものをご回答いただいていますがベースにして応用するためにと思いました。

D列～G列まで各列に２０行のセルに関数式で得られたデータが入っているものとします。
各列最終行（この場合は21行目）は空欄（関数式なし）
これを縦１列にD1～D20～E1～E20～F1～F20～G1～G20に並べ変えてテキストを生成したい。
例では、D～G列は４グループですが、D～H等グループ数を変えたい場合の修正部分

補足

＞最近文字化けが発生する
q6435241でいただいたものを移行準備のためにときどき使用しているのですが
これが文字化けになることがたまにあるのです。
移行後は本格的に使用しなくてはならず、そこで以前DOUGLAS_様に作っていただいたものをアドレス変更後にも使いたくてお願いする次第です。