エクセルの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.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以外でも見られます。

回答No.14

DOUGLAS_

＞ただ過去のデータで・・記述がたくさんあったため
＞万一あったときのための気休め程度の存在です。
と心配していらっしゃいますが、恐らく、そういうことはご心配要らないかと存じます。

　と申すよりは、こういう「ＷＥＢデータ の取り込み」においては、その ＷＥＢページ の作りに合わせて、取り込み側で逐一方法を考え、サイト側 で サイト の作りを変更したような場合には、方法を考え直すのが常道かと存じますし、まして、過去の サイト構成 データ を取り込むための「計算式」を温存しておく意味は皆無かと存じます。

　従いまして、今般読み込んでいる サイト の冒頭の２行
Ch.４０１ Ｊ－ＰＯＰ最新ヒットチャート
放送日 ： ２０１１／７／２５～２０１１／７／３１ 「番組案内　（４時間サイクル）」
から「■110725SD401」を生成するだけでよろしいのでしたら、全部の行に、その「計算式」を挿入する必要は全くなく（サイト の構成を私が検証いたしました）、マクロ の中で、冒頭の２行を「■110725SD401」というように変えてしまえばよいかと存じます。

　そういう理解でよろしいでしょうか？【問18】
　もし、まだ、不安が残るようでしたら、冒頭の成形作業は、「繰り返し用_改訂版」のままで、マクロ には入れないことにいたしますので、文末の「テスト３」をお試しいただいてから、成形作業を マクロ に入れるか入れないかをお返事ください。【問19】

　また、入れる場合、この文字列の間にある「SD」は、すべての ページ で「SD」のままでよろしいでしょうか？【問20】

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

＞Lotusの方は２種類つくっていてChによって使い分けています。
　詳しくご説明いただいてよく分かりました。

＞説明するのにシートを直接見
なければ分かりそうにもありませんので、【問16】の方は、無かったことにさせてください。
　却って無駄な時間を費やさせてしまいまして、誠に申し訳ございませんでした。　　<(_ _)>

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

＞問１７　xlsの場合
こちらは必要ありません。

＞標準のxlsxを使用した場合、保存の段階で
＞次の機能はマクロなしのブックに保存できません
　これは、保存しようとしている 新規ブック で「新しいマクロの記録」をされたからです。別の ブック に記録すれば、この エラー は出ないと存じます。

　「ANo.10」の「お礼」に書いていらっしゃった
＞開こうとしているファイルが実際はその
＞拡張子が示すファイル形式ではありません。
の メッセージ につきましては、
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200901/09010064.txt
を拝見して、大体予想通りだと思われました。

　つまり、「xls」で保存すると「FileFormat」が「xlExcel8」となり、
Filename:="D:\Book1.xls", FileFormat:=xlExcel8
「xlsx」で保存すると「FileFormat」が「xlOpenXMLWorkbook」となっているようですので、
Filename:="D:\Book1.xlsx", FileFormat:= xlOpenXMLWorkbook

　従いまして、「ANo.10」に書きましたように、
＞「.xls」の拡張子は、「.xlsx」に変更
するだけで行けるはずです。

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

　さて、最後になりましたが、恐らく、これが最後の テスト になるかと存じます。
　401チャンネル を開いて、ワークシート に展開する マクロ ですが、<<< 新規の ブック に 標準モジュール を挿入して >>> お試しいただいて、上記の質問にお答えください。

　なお、冒頭の２行は、
■110725SD401 「番組案内　（４時間サイクル）」
にまとめました。

'-------------------------------------------------
Sub テスト3()
　Dim objHttp As Object
　Dim myTbl As Variant
　Dim CB As New DataObject
　Sheets("Sheet1").Select
　Set objHttp = CreateObject("MSXML2.XMLHTTP")
　With objHttp
　　.Open "GET", "http://www.stardigio.com/songlists/txtdata/lists1/401.txt", False
　　.Send
　　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"
　　With CB
　　　.SetText myTbl(0) & Mid(myTbl(1), InStr(myTbl(1), vbTab))
　　　.PutInClipboard
　　　.GetFromClipboard
　　End With
　　Range("A1").Select
　　ActiveSheet.Paste
　　Columns("A:A").Replace "楽曲タイトル", ""
　　On Error Resume Next
　　Columns("A:A").Find("個人的に楽しむ場合を除き").Resize(2).Clear
　　On Error GoTo 0
　　Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　　Columns("A:B").Columns.AutoFit
　　Range("A1:B1").Select
　　ActiveWindow.Zoom = True
　　Range("A1").Select
　End With
　Set objHttp = Nothing
End Sub

お礼

今度のテストは呼び込みがおっそろしく早いですねぇ!
これはばっちりでした。
関数についてはご指示どおり排除してけっこうです。

問１８／問１９
１行目を
■110725SD401に変えていただければけっこうです。
※なお、今頃気がついたのですが、開始時間の行は削除対象のものでした。
したがって上記は１行目だけでかまいません。

問２０
日付の次はすべてSD（半角）になります。

これはVBAの中にチャンネル番号が記述されていますが、実際には前回のような連続もしくはテキストボックスの数値を当てはめることになるのですね

あと、前回以来せっかくご指導いただく機会ができたので、前回の分について、サイト名（記述式）が変更になってしまったのでここで修正の方法をお願いしてよろしいでしょうか。
後に別の方に別のVBAを教えていただきましたが、最近文字化けが発生することが多いのでやや困っていました。

回答No.13

DOUGLAS_

先ず、
＞A11の関数式が消える問題は
＞～～～により解決しました。
に付きましては、私の配慮が足らなかったことで、想像通りです。

＞A12のご質問は
＞３）になりました。
　これは、ラッキー です。
　次の マクロ をお楽しみになさってください。

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

＞関数式はD～Hに入っています。
とのことですが、実際に、ＷＥＢの表をＡ・Ｂ列に貼り付けてみましても、
Ｅ列＝Ｇ列＝　　　Ａ列
Ｄ列＝Ｆ列＝Ｈ列＝Ｂ列
となって、何の為の関数なのか全然分かりません。

　ただ、表中の２行目の
放送日 ： ２０１１／７／２５～２０１１／７／３１
が
■110725SDネル:
になっているのと、
■J-POP最新ヒットチャート
の後に余分な スペース が入っているのが トリム されているだけです。

＞何の目的でいれたのかわからなくなってしまいそのまま放置
とのことですが、仰る通りかと存じます。
　ですので、　
＞このG列とH列をコピペして別作業に使
うのではなくて、Ａ・Ｂ列に貼り付けた時点で、すべての セル を トリム してしまえば、「関数式」は全く不要です。

＞G列とH列をコピペして別作業に使います。
＞ここから先はLotus123シートで作成
とのことですので、「関数式」を全く消してしまって、サラの「Sheet1」シート で マクロ を実行し、そこに出来た Ａ・Ｂ列 の値を Lotus123 でご利用になったら、「G列とH列をコピペ」しておられたときと比べて、何か不具合がありますでしょうか？【問15】

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

＞ここから先はLotus123シートで作成してしまった
とのことですが、この際、「毒を食らわば皿まで」
＞その部分も改めてエクセルで作り治
されたらいかがでしょうか？

＞またVBAや関数を色々考える
ほど、大変な作業をしていらっしゃるのでしょうか？

　「繰り返し用_改訂版」マクロで、ある程度成形されたＡ・Ｂ列の データ ですが、ここから、お好きな アーティスト だけを抜粋するとかいうような、noro6857 さんのご趣味による作業でしたら、そのまま Lotus123 で行なわれるのが無難でしょうが、そんなに難しくない作業でしたら、ついでに、この マクロ の続きでやっつけた方が便利かと存じます。

　<<< もしも >>> 簡単そうな作業でしたら、仰っていただいたら、この際、「乗りかけた船」で考えさせていただきますが、いかがでしょうか？【問16】

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

＞VBAの保存拡張子をxlsmに直したら、
＞「対応していない拡張子」とかでとまってしまった
につきましては、次の事をお試しいただき、(５) の結果をお知らせください。【問17】

１）新規の ブック を起動します。
２）「新しいマクロの記録」を開始します。
３）この ブック を Ｄドライブ の直下に、Excel 2010 の標準ファイル形式で、「hoge」とでも名前を付けて保存します。
４）「新しいマクロの記録」を終了します。
５）ＶＢＥで「ActiveWorkbook.SaveAs」の後に、何と書かれているか確認します。
６）「D:\hoge.xl??」を削除します。

お礼

E2はA1のChとA2の放送日付をコード化させています。
■110725SD401
たしかにそれ以外はソースデータと全くかわりませんね。
ただ過去のデータで

メトロ に乗って 浅草 へ 上 々 颱風
ダンシング ・ オールナイト もんた & ブラザーズ
My Babe 君が 眠るまで シャ 乱 Q

のような記述がたくさんあったため、単にTRIMだけではなおらなくて、
OKWavでの協力を得ながらこの関数を書き込んだ記憶があります。
現時点ではこのようなソースが見当たらないのでこのままならば
E2以外は関数を使う必要はないかもしれません。
万一あったときのための気休め程度の存在です。
E2のコードはいずれすべての行に付すために残す必要はあるので、
コピペの際１行目にくるような方策があれば関数は不要なります。
あるいはこのままcopyしてLotus側で作ってもいいかもしれません。（問１５）

Lotusの方は２種類つくっていてChによって使い分けています。
chの記述は
401,423のように1～ENDまで通しの場合
403,410,412のように通しではあるが途中に■が入る場合
418,429のように途中から内容が変わるため連番を変更する必要がある場合。
411.426のように年度が出てくる場合、その年度を各行に折り込む場合。
等がありこれらを
■がはさまったch曲目リスト一覧（放送される際■部分は間奏が流れます）
■をのぞいたch 曲目／歌手／曲目（歌手）／110725SD401-01曲目（歌手）／曲目（歌手）110725SD401-01／01曲目（歌手）
（年度が入る場合－曲目[98]のようになる）
■だけの行を集めたタイトルリスト
また各先頭行は■110725SD401最新チャート＋１曲目タイトルあるいは■110725SD405AKB48特集＋１曲目タイトル
というふうな形を表示させています。

これらをかつてお願いしたように、たて１列のテキストに置き換えるマクロを使うので、これらをすべて
エクセル１発でやったほうがかなり楽かとは思っていますが
説明するのにシートを直接見ていだけば分かりやすいのですが、説明だとなかなかうまくできそうもなく、
内容によってそのchだけのための手直しもあったりして
常にその都度お尋ねできる環境ではないため、せっかくのご好意ですが当面はLotusのままで進めさせていただこうと思っています。【問16】
問１７
xlsの場合
ActiveWorkbook.SaveAs Filename:="D:\Book1.xls", FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

標準のxlsxを使用した場合、保存の段階で
次の機能はマクロなしのブックに保存できません・VBプロジェクト
これらの機能が含まれるファイルを保存する場合は「いいえ」をクリックしファイル名で「マクロ有効のファイルを選択、マクロなしのブックとして保存いする場合は「はい」
により「はい」を選択したものです。
ActiveWorkbook.SaveAs Filename:="D:\Book1.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False

回答No.12

DOUGLAS_

【追加のお願い】
　下記の テスト マクロ を実行して、表示される メッセージ を下記からお答えください。【問14】
１）「２はダメ」
２）「１もダメ」

(１) でも (２) でも無い場合、
３）「■J-POP最新ヒットチャート」で始まる長～いメッセージ
４）何やら長～い メッセージ が表示されているが、文字化けしていて読めない。

Sub テスト2()
　Dim objHttp As Object
　On Error Resume Next
　Set objHttp = CreateObject("MSXML2.XMLHTTP")
　If Err.Number <> 0 Then MsgBox "２はダメ": Set objHttp = CreateObject("MSXML.XMLHTTPRequest")
　On Error GoTo 0
　If objHttp Is Nothing Then MsgBox "１もダメ": Exit Sub
　With objHttp
　　.Open "GET", "http://www.stardigio.com/songlists/txtdata/lists1/401.txt", False
　　.Send
　　MsgBox Mid(.responseText, 136)
　End With
　Set objHttp = Nothing
End Sub

お礼

A11の関数式が消える問題は
「この コード を
Sheets("Sheet1").Copy
の後に持って行けば」
により解決しました。

回答No.11

DOUGLAS_

先ず、
＞関数式がひとつめのブックでは問題ないのですが、
＞ふたつめ、みっつめと進むうちに下の方から
＞だんだん式が削除されてしまい、
＞１０こめのBookでは１行目の式しか残っていませんでした。
　これは、
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
によって、回数が進むにつれて、行数が減っていくためです。

　私の配慮が足りませんでした。　　<(_ _)>

　この コード を
Sheets("Sheet1").Copy
の後に持って行けば、問題はなくなるかと存じますが、私的には、そもそも、noro6857 さんのお手許の ブック に「関数式」がどのようにちりばめられているのかが気になります。

　例えば、C1:H1 まで、いろいろな数式が立てられているとして、これを最終行まで オートフィル しただけの「関数式」なのか、あるいは、（これは無いかとは存じますが）行によって「関数式」が違うのか？【問９】
　前者であるとすれば、「C1:H1」の範囲は「C1:」からどこまでなのか？【問10】

　前者であれば、ＷＥＢの表を貼り付けて成形した後に、C1:H1 を最終行まで コピー する方が、ワークシート としての見栄えも数段よくなるかと存じます。

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

＞２０１０のマクロ有効ファイルはxlsxでなく
＞xlsmでしたのでその拡張子で試しました。
　そうですね。仰るとおり、「マクロ有効ファイル」の拡張子は「xlsm」のようですが、チャンネル ごとに保存する ブック には、マクロ は含まれないかと存じますので、「xlsx」でよいのではないでしょうか？
　それとも、「Sheet1」に シートモジュール でも書かれているのでしょうか？【問11】

＞生成されるシートはxlsで作られるため、
＞出来上がりを開くときにその都度メッセージが・・・
　これは、どういうことでしょうか？

ActiveWorkbook.SaveAs ～～～ .xls
の行の最後の「xls」を「xlsm」なり「xlsx」に書き換えていらっしゃいますか？【問12】
　書き換えて マクロ を実行していらっしゃるのに、
＞生成されるシートはxlsで作られる
とは、どういう意味でしょうか？
ActiveWorkbook.SaveAs ～～～ .xlsm（xlsx）
にしても、「.xls」で保存されてしまうのでしょうか？【問13】

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

＞出来上がりがどうも安定しなくて・・・
＞（STOPはいずれもペーストできないとのメッセージ）
　恐らく、ＷＥＢ からの ダウンロード が上手くいっていないのではないかと思われます。

　この点に付きましては、今朝、画期的な方法を思い付きましたので、上記の質問にお答えいただいてから、
＞Book単位での作成なので前段のマクロを使いました）
＞削除行はうまく処理されていました。
を踏まえて、再度、コード を書き直します。

お礼

問9/問10
関数式はD～Hに入っています。
無駄な式が入っているとまた叱られそうですが、何度も継ぎ足しで書き加えたのと何の目的でいれたのかわからなくなってしまいそのまま放置してあります。
たぶん曲名とアーチスト名（１行目と途中見出しはタイトルコード）を再表示させているのですが、実は以前のこのサイトは、文字間にスペースが頻繁に入り込んでいたため、これを排除するために関数を入れたような気がします。
たぶんもう一度やりなおせば不必要な関数式もありそうです。
当然呼び出しデータの行まででいいのですが、あらかじめ200行くらいまで入れてあります。

D
=TRIM(IF(C1="",B1,B1&C1))
E
=IF(ISERR(FIND("放送日",A1)),A1,"■"&ASC(MID(A1,9,2)&"0"&MID(A1,12,1)&MID(A1,14,2))&"SD"&ASC(MID($A$1,4,3)))
F
=IF(D1="","",IF(ISERROR(FIND(" ",TRIM(D1))),D1,IF(ISNUMBER(FIND(" ",TRIM(D1))),IF(LENB(MID(TRIM(D1),FIND(" ",TRIM(D1))-1,3))-LEN(MID(TRIM(D1),FIND(" ",TRIM(D1))-1,3))>1,SUBSTITUTE(TRIM(D1)," ",""),TRIM(D1)))))
G
=TRIM(E1)
H
=TRIM(F1)

このG列とH列をコピペして別作業に使います。
（実はここから先はLotus123シートで作成してしまったため、このような方法をとっています。その部分も改めてエクセルで作り治せばその必要もないのですがまたVBAや関数を色々考える必要があるため当面手抜きしています。）

問１１／１２／１３
VBAの保存拡張子をxlsmに直したら、「対応していない拡張子」とかでとまってしまったので、デフォルトのxlsのままにしてあります。
xlsでもセキュリティを「低」にしてマクロは実行されるようにしています。

なおA12のご質問は
３）「■J-POP最新ヒットチャート」で始まる長～いメッセージ
になりました。

回答No.10

DOUGLAS_

＞「’」をつけないとA4のメッセージが出てしまい実行できません。
＞つけると・・・ペーストエラー(A5)になってしまいます。
＞つまりctrl+Vで貼り付けはできる）
　ん～～。原因が分かりませんねぇ。。。

　とりあえず、
＞1chごとに新しいBookSheetに保存するので
＞chごとの呼び出しは常にA1になります。
ということですので、マクロの中で、操作の始めにＡ・Ｂ列の内容を クリア し、そこに貼り付けるようにしてみましょう。

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

　noro6857 さんは Excel2010 をお使いのようですので、「.xls」の拡張子は、「.xlsx」に変更してお試しください。

１）データ ドライブ に適当な 試験用の フォルダ を作成し、「既存の関数入りのsheet」のある ブック を コピー します。
　例えば、「D:\hoge\関数入り.xls」
２）「D:\hoge\関数入り.xls」に 標準モジュール を挿入し、下記の マクロ を コピペ します。
３）「既存の関数入りのsheet」を「Sheet1」とし、「Sheet2」のＡ列に、読み込みたい チャンネル の番号を羅列します。
　例えば、「A1:401、A2:405、A3:411、A4:456」
４）マクロ を実行します。

　その結果「D:\hoge\」フォルダ に
401Ch_(20110724) .xls
405Ch_(20110724) .xls
411Ch_(20110724) .xls
456Ch_(20110724) .xls
という４つの ブック ができます。

　マクロ の操作内容は、
１）Sheet2 の 空白セル を削除し、Ａ列 の値を配列に格納。
２）Sheet1 にて、繰り返し作業開始。
３）１チャンネルずつ、データ を読み込み、ワークシート に転記。
　存在しない チャンネル ページ を参照したときは、エラー メッセージ を表示。
４）「楽曲タイトル」と「個人的に楽しむ場合・・・」以下の２行、及び空白行を削除。
５）Sheet1 を「{チャンネル番号}Ch_{日付}.xls」という名前で、マクロブック と同じ フォルダ に保存。
以上です。

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

Sub 繰り返し用_改訂版()
　Dim myList As Range
　Dim objIE As Object
　Dim myCh As Variant
　Dim myTbl As String
　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 objIE = CreateObject("InternetExplorer.Application")
　With objIE
　　Sheets("Sheet1").Select
　　For myCh = 1 To myList.Count
　　　Application.StatusBar = myList(myCh) & "チャンネルを読み込んでいます。"
　　　.Navigate "http://www.stardigio.com/songlists/lists1/" & myList(myCh) & ".html"
　　　Application.Wait (Now + TimeValue("0:00:05"))
　　　If InStr(.Document.body.outerHTML, "このサイトの中には見つかりませんでした") > 0 Then
　　　　MsgBox myList(myCh) & "チャンネルのページは見つかりませんでした。"
　　　Else
　　　　myTbl = objIE.Document.getElementsByName("SongLists")(0).outerHTML
　　　　Columns("A:B").Clear
　　　　With CB
　　　　　.SetText myTbl
　　　　　.PutInClipboard
　　　　　.GetFromClipboard
　　　　End With
　　　　Range("A1").Select
　　　　ActiveSheet.Paste
　　　　Columns("A:A").Replace "楽曲タイトル", ""
　　　　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 ThisWorkbook.Path & "\" & myList(myCh) & "Ch_(" & Replace(Date, "/", "") & ") .xls"
　　　　ActiveWorkbook.Close
　　　End If
　　Next
　　Application.StatusBar = ""
　　.Quit
　　Columns("A:B").Clear
　End With
　Set objIE = Nothing
　Application.ScreenUpdating = True
End Sub

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

　上記の マクロ は、チャンネル ごとに新しい ブック に保存するようにしていますが、１つの ブック に、チャンネル ごとに、新しい シート を追加する、という意味でしたら、変数の宣言部に
Dim newBook As Workbook
を追加し、

'-------------------------------------------------
　　　　Sheets("Sheet1").Copy
　　　　ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & myList(myCh) & "Ch_(" & Replace(Date, "/", "") & ") .xls"
　　　　ActiveWorkbook.Close
　　　End If
　　Next
'-------------------------------------------------

の部分を

'-------------------------------------------------
　　　　If myCh = 1 Then
　　　　　ThisWorkbook.Sheets("Sheet1").Copy
　　　　　ActiveSheet.Name = myList(myCh) & "Ch"
　　　　　ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Replace(Date, "/", "") & ".xls"
　　　　　Set newBook = ActiveWorkbook
　　　　Else
　　　　　ThisWorkbook.Sheets("Sheet1").Copy After:=newBook.Sheets(newBook.Sheets.Count)
　　　　　ActiveSheet.Name = myList(myCh) & "Ch"
　　　　　ThisWorkbook.Activate
　　　　End If
　　　End If
　　Next
　　newBook.Activate
　　Sheets(1).Select
　　ActiveWorkbook.Save
　　ActiveWorkbook.Close
'-------------------------------------------------

に差し替えてお試しください。

　この場合は、「D:\hoge\」フォルダ に
20110724 .xls
という ブック ができて、その ブック には、
401Ch、405Ch、411Ch、456Ch
という４つの シート ができます。

お礼

きのう回答を書き込んだつもりでしたが、入力し忘れたようで失礼しました。

この方法だと一気にできてしまうのですね。
毎週同じチャンネルの選択なので、一度必要チャンネルを入力しておけばいちいち一つずつ入力手間がかからずこれなら重宝します。
ということで早速試してみました。
（Book単位での作成なので前段のマクロを使いました）

２０１０のマクロ有効ファイルはxlsxでなくxlsmでしたのでその拡張子で試しました。
ただ、出来上がりがどうも安定しなくて、ひとつも生成されずにペーストエラーになったり、１０くらい指定するうちの５つくらいでとまったり、もちろん全部作られるときもありました。（STOPはいずれもペーストできないとのメッセージ）
この因果関係はよくつかめません。
今朝再度トライしてみたらすべてのファィルが生成されました。理由はよくわかりません。
削除行はうまく処理されていました。特に途中の空白行も削除できたらと思っていましたのでこれも削除されていていい仕上がりになりました。
ただし、ひとつだけ問題が。
関数式の入っているブックに取り込んでいるのですが、その関数式が
ひとつめのブックでは問題ないのですが、ふたつめ、みっつめと進むうちに下の方からだんだん式が削除されてしまい、１０こめのBookでは１行目の式しか残っていませんでした。

あと生成されるシートはxlsで作られるため、出来上がりを開くときにその都度メッセージが「開こうとしているファイルが実際はその拡張子が示すファイル形式ではありません。コノファィルを開く前に、ファイルが破損していないこと、信頼できる発行元のファイルであることを確認してください」と出て、かまわずそのまま開けば取り込まれたファイルであることには変わりません。これはメッセージがわずらわしいだけで問題はありません。

回答No.9

DOUGLAS_

＞ADSL回線は3.4Mbbsしか出ていません。
　パソコン自体は、そこそこ性能の良いものをお使いのようですので、まさかとは思いましたが、やっぱりお尋ねして良かったです。
　これが原因ですね!!
　性能の良い パソコン で、プログラム の方はバシバシ動くのに、ＷＥＢページ の内容を ダウンロード するのに時間が掛かっているという図です。

＞５秒にしたところ取り込めました。
　恐らく、
Application.Wait (Now + TimeValue("0:00:05"))
にすれば、
myTbl = Left(myTbl, InStr
の行の頭に「’」を付けて コメントアウト しなくても大丈夫かと存じます。

　つまり、
＞欄外の注はあってもかまわない
という心配はなくなると存じます。

　もし、上記で上手く行かなくて
＞「行の頭に「’」を付け」にするとうまく取り込めました
ということでしたら、
If Selection.Address = "$A$3" Then Range("A1").Select
の時点で、貼付け位置を３行上に持っていけば済むことですが。。。

＞「楽曲タイトル」の行の削除ですが、
＞取り込んだあと別マクロで作業してもいい
　次の事をお試しください。

１）待ち時間を「５秒」にする。
２）「myTbl = Left(myTbl, InStr・・・」の行の頭の「’」は付けない。
３）プログラム を実行する。
　これで、ワークシート に データ が ダウンロード できるかどうかお知らせください。【問５】
　「既存の関数入りのsheetでも同じ方法」で行けるかどうかもお試しください。【問６】

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

＞ときどき 「実行時エラー１００４ ということが発生
＞ctrl+Vにより手動で貼り付けを行うことで対処
　これは、
ActiveSheet.Paste
の行で エラー により、マクロ が止まった時点で、<<< 本来、貼付けるべき場所（Ａ列最終行から１行空白行を空けて次の行）に >>> 手動で貼付けておられるということですか？【問７】

　もし、同じ場所（Ａ列最終行から１行空白行を空けて次の行）であるということなら、エラー の原因が分かりません。

　試しに、エラー が出たときに、イミディエイト ウィンドウ に
? Selection.Address
と入力して、[Enter] を押下し、そこに出る アドレス（例えば「$A$27」）が、「Ａ列最終行から１行空白行を空けて次の行」になっているかどうかお知らせください。【問８】

＞A列B列のセルはなにも書かれていないけれど
＞これをいったん削除してみると取り込めるようになりました。
＞既存の関数入りのsheetでも同じ方法で可能でした。
　ますます、不可解ですが、とりあえず、上記の質問にお答えいただいてから、順に処理していきましょう。

お礼

問５
１）待ち時間を「５秒」にする。
２）「myTbl = Left(myTbl, InStr・・・」の行の頭の「’」は付けない。
３）プログラム を実行する。

で試しましたが、残念ながら２）の「’」をつけないとA4のメッセージが出てしまい実行できません。
つけるとダウンロードはできているようですが、やはりペーストエラー(A5)になってしまいます。
（つまりctrl+Vで貼り付けはできる）
【問６】
関数入りsheetでも同じ状況です。
【問７】
以前の説明が不十分だったかもしれませんが、連続作業という意味はBookSheetの下段に異なるchを続けて呼び出すのではなく
1chごとに新しいBookSheetに保存するのでchごとの呼び出しは常にA1になります。
したがってA5の停止状態ではカーソルがA1にあるためそこに手動ペーストをしている訳です。
やり方は401Chを呼び出したら、ファィル名を決めて保存し、そのシートのA列B列の呼び出しデータを削除し、次のChをこれに呼び出しこれをまた別の名で保存するという繰り返しをしています。
（ということはテキストボックスの入力も、その都度１回で終わらせてもかまいません）
このため問８については試していません。

＞A列B列のセルはなにも書かれていないけれど
というのは、もしかしたらA列B列になにか見えないデータやあるいは前のデータの残骸でもあってペーストの邪魔をしているのかと思って念のために削除しているもので、その結果がたまたま呼び出せたというものかもしれません。

回答No.8

DOUGLAS_

＞お手数をおかけします。
　ぃぇぃぇ、http://okwave.jp/qa/q6129006_2.html を思い出しますゎ　　（＾凹＾）

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

＞いずれでもTESTマクロでは「こんにちわ」までたどり着きました。
　ということは、(甲)ＩＥオブジェクトの読込、(乙)表部分の htmlコード の取り込み、(丙)クリップボード オブジェクト の操作、以上３点が問題なく行なわれているということになります。

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

＞サンプルコード１による場合は、
＞差し替えた・・・ところで
＞No４と同じメッセージになりました。
　では、先ず、
myTbl = Left(myTbl, InStr(・・・
の行の頭に「’」を付けて コメントアウト し、それから マクロ を実行してみられるとどうなりますでしょうか？【問１】

　この行は、表の末尾にある「＊個人的に楽しむ～～～御了承下さい。」の２行を削除するための コード ですので、さほど重要ではありません。

　次に、下記の操作の結果をお知らせください。【問２】

１）「myTbl = objIE.Document・・・」の行で [F9] キー を押下して ブレークポイント を置きます。
２）[デバッグ(D)] - [ウォッチ式の追加(A)...] で [ウォッチ式の追加] ダイアログ を開き [式(E):] に「myTbl」と入力して [OK] を クリック します。
３）[F5] キー で一気に マクロ を実行します。
４）「myTbl = objIE.Document・・・」の行で マクロ が止まりますので、それ以降は [F8] キー を押下して ステップ イン デバッグ します。
５）エラー が出た時点で、イミディエイト ウィンドウ を開き（そこに何か書かれていた場合は、[Ctrl] + [A] ですべて選択して、[Delete] キー で、削除してください）、「? myTbl」と書いて [Enter] を押下してください。
６）その結果、(ア)「? myTbl」の下に「空白または改行」だけが２～３行表示された場合は、上記の (乙) が出来ていないということになります。

　(イ)「空白または改行」ではなくて、「<div id="SongLists"」で始まる長～い文字列が表示された場合は、「htmlコード の取り込み」はできているけれども、その中に「class="caption"> 」という文字列がないので、「InStr(・・・)」が「0」になり、つまり、「InStr(・・・) - 1」の値が「-1」となって「Left(myTbl, InStr(・・・) - 1)」の式の意味が「myTbl の左から -1 文字分」ということになります。
　従って、「No４と同じメッセージになりま」す。

　後者の場合は、きちんと「htmlコード の取り込み」が出来ていないことになりますが、その原因は分かりません。
　２～３秒経って [F8] キー を押下したら、問題なく次に進むこともあります。

　気休めに
Application.Wait (Now + TimeValue("0:00:2"))
を「３秒」とか「５秒」に変えてみるといかがでしょうか？【問３】

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

＞サンプルコード２の場合は、
＞数字入力Boxで数字を入れたあと
＞再度数字入力Boxが表示される繰り返しになってしまいました。
　これは、恐らく、上記の (乙) が出来ていない状態ではないかと思われます。

　ということは、「サンプルコード２」は非常に冗長な コーディング になっておりますので、この際、切り捨てて「サンプルコード１」の方でお考えください。

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

　ちなみに、プロフィール を拝見すると、「ADSL」回線とお書きですが、下り速度は
http://www.musen-lan.com/speed/
で計ると、どのくらい出ていますでしょうか？【問４】
　私の環境（Yahoo! 12MB、基地局から約2km）で計ると、「推定転送速度： 5.94Mbps (742KB/sec)」と計測されました。
http://www.bspeedtest.jp/
で計ると、「下り受信速度: 5.9Mbps(5.99Mbps,749kByte/s)」と出ました。

＃それと、これは憶測ですが、「ANo.5」の「実行時エラー 1004」は、既存の ブック でその マクロ を実行した場合に、Ｃ列以右の計算式に不合理が生じているような気もします。

お礼

「を思い出しますゎ　　（＾凹＾）」
そうですねぇ。あのときはずいぶん親切にしていただき感謝しています。
あのマクロは現在でも重宝していて毎日のように活用していますが、あいにくとあの放送局が７月末で終了となるため、別の局の同内容を掲載した別サイトからの取り込みとなってしまうので、後に別の方（本当はDOUGLAS_様での回答がつながることを期待したのですが）に教えてもらったWEB取り込みマクロを使用することになりますが、取り込み後の並べ替えマクロは引き続き利用させていただくことになります。
しかし、「勉強します」といっておきながら相変わらず他の方をたよりにしてしまい恥ずかしいです。

さて、
問１ですが
「行の頭に「’」を付け」にするとうまく取り込めました。（問３も含めて）
欄外の注はあってもかまわないのでこれでいけるかと思います。

問２ですが
「始まる長～い文字列が表示」されました。

問３
５秒にしたところ取り込めました。

したがってA3のコードにより問１／問３の処理をすることでなんとかなりそうです。

「なんとか」というのは
どういう加減かよくわかりませんが、ときどき
「実行時エラー１００４
Worksheetクラスのoasteメソッドが失敗しました。」
デバック
ActiveSheet.Paste
ということが発生することがあり、そのときはctrl+Vにより手動で貼り付けを行うことで対処できています。
また、読み込めないとき、にA列B列のセルはなにも書かれていないけれどこれをいったん削除してみると取り込めるようになりました。
既存の関数入りのsheetでも同じ方法で可能でした。

あとはA列に「楽曲タイトル」の記述のある行の削除ですが、取り込んだあと別マクロで作業してもいいかと思います。find関数のようなものを使うことになりましょうか。

※ADSL回線は局から2Kmを超える所の環境のため残念ながら3.4Mbbsしか出ていません。Yahoo! 50MBに入っていてもなんとなく無駄のような気がします。
（光はちょっと高いし。ちなみに加入ADSLはNexyBBといって50Mbbsで月2998円です）

回答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が表示される繰り返しになってしまいました。

回答No.6

DOUGLAS_

＞VBA実行時にエラーしました。
　ん～。。。ホントに環境に左右されるんですねぇ。。。

　前回答への「お礼」のエラーは出ないパソコンもありますし、今回のエラーも私の手許のパソコンでは発生しません。

　「原因が特定できない」＆「相変わらずエラーになる」ということでしたら、ＷＥＢテーブル を ワークシート に展開する方法そのものを変更しなければなりません。

＞取り込めるようになったらひとつだけ追加VBA記述を
＞お願いしようかと思っていたのですが、
＞ここでお願いしておきたい思います。
　ここでお尋ねいただいていて良かったです。

＞411chで８か所
　「ANo.3」の コード のままでは、「411ch」では、一番上の表しか取り込みができませんでしたので、ＷＥＢテーブル を ワークシート に展開する方法そのものを変更して、もう一度、最初から考え直してみます。
　もうしばらくお待ちください。

お礼

C列以降に関数を各行に書き込んであるBookSheetにVBAを追加して取り込もうとしたところ上記エラーになりました。そこで新しいBookSheetでVBAを書き込んでみたんですがやはり同じ結果でした。（環境が違うと動かないこともあるんですぇ。ＰＣの気分はよくわかりません！）

なおエクセルは2011でなく2010の誤りでした。
またPCはXPProSP3,corei5,RAM4G、HDD2TBの自作PCです。

お手数をおかけします。急ぐものではありませんのでお時間の許す範囲内でよろしくお願いします。