Greenroom?

番外編、習作ですから ^ ^;

>こちらの方がメモリ的にも速度的にもかなり有利ですよね。
いやそんな事はなく？
やっぱり再帰が速いです。
課題Ａはともかく、重い課題には不向きだと思いますorz

しばらくひねくり回してようやく判った…ような…気がするだけかも(汗

　#　Doループが子Ｐに相当する部分で
　#　lvはその階の起点番号兼管理番号でitmIdx、nはForループのiに当たると。

　#　根方向各階のiとrmnSumを配列xと配列wで管理して
　#　lvインクリメントで次の階へ進む、デクリメントで戻る

　#　で、lvが一番上まで戻ってきたらメデタシメデタシ。
　#　…であってるかしらん？

思いっきりこんがらかっちゃいましたww
わたしにはこういうまわし方は到底無理デス　orz

　#　きっと「手続き」的なイメージで捉えてる時点でダメなのね。

　#　再帰にしても、「舐める」とか「枝」とか言ってる割に全然木意識してなくて
　#　投げっぱなし呼びっぱなしの関数感覚だから、戻るときの処理で毎度あたふたするしw

こちらの方がメモリ的にも速度的にもかなり有利ですよね。
スタック喰い潰しながら時間かけて再帰するのって
打鍵猿並にエレファントな気がしてきました(苦笑

少しだけ「向上を志向」してがんばってみようかしら…。

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

■>アルゴリズムって苦手なんで

わたしもです(^^;;;;;;;

ランダウ記号とか出てくるともうそれだけで
「センター、フェンスを見上げたまま一歩も動けません！」
な状況なんですが、
「素朴に再帰するだけ」でこれだけの結果が得られるのに
なんでソルバーだの動的計画法だのが出て来るんだと…。

■>不親切なコードで醜いですけど

いえいえ、いつもながらすっきりして見やすいコードだなぁと。
意図が判らないのはわたしのアタマの都合ですからw

わたしの場合、ブロックが大きくなるとインデントつけても混乱しちゃうんですよね。
で、片っ端から切り出したら今度はスパゲッティになるという…。

変数名も、キャメルとかハンガリアンとかこだわってるわけでは全然なくて
本当は短くして「白いコード」にしたいんですけど…やはり本人が判らなくなるという。
…「わたしの知らない予約語」とかぶらないよう長くしてるというのはナイショですw

■>本スレを汚したくなかったので

どうぞおかまいなく。
ほんとに「下書」ですし、すでに色々汚れてますし　o　....rz

部分和スレッド、たいへん勉強になりました。m(_ _)m

普段からアルゴリズムって苦手なんで突っ込んだ事なかったんですが
今回は判り易くて理解できました。
特に、総当たりから始まって、
『ver.0.40～：　課題Ａ0.08秒への途』以降の繋ぎは素晴らしいですね。
アウト判定をきっちりやる事でこんなに速くなるとは驚きです。

本スレ参考にして、私も不再帰パターンでまず習作してみました。
（再帰編もちょっとだけ）
型や、読み込み・書き出しはあまり意識せず、従来パターンを使ってます。
例のごとくｗ不親切なコードで醜いですけど

Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub test()
　　Dim CHK As Long
　　Dim tmp As Long
　　Dim cnt As Long
　　Dim mx　As Long
　　Dim lv　As Long
　　Dim n　 As Long
　　Dim i　 As Long
　　Dim v, w, x, buf, vSum, ret

　　Dim tChk As Long
　　tChk = timeGetTime
　　
　　With ActiveSheet
　　　　With .Range("B1", .Range("B1").End(xlDown))
　　　　　　.Sort Key1:=.Item(1), _
　　　　　　　　　Order1:=xlDescending, _
　　　　　　　　　Header:=xlNo, _
　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　MatchCase:=False, _
　　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　　SortMethod:=xlStroke
　　　　　　v = Application.Transpose(.Cells)
　　　　End With
　　　　CHK = .Range("A1").Value
　　End With

　　mx = UBound(v)
　　ReDim w(0 To mx) As Long
　　ReDim x(0 To mx) As Long
　　ReDim buf(1 To mx) As Long
　　ReDim vSum(1 To mx) As Long
　　ReDim ret(1 To 20000)

　　For i = mx To 1 Step -1
　　　　tmp = tmp + v(i)
　　　　vSum(i) = tmp
　　Next
　　If tmp <= CHK Then Exit Sub
　　
　　w(0) = CHK
　　lv = 1
　　n = 1

　　Do
　　　　If w(lv - 1) > vSum(n) Then
　　　　　　buf(lv) = Empty
　　　　　　w(lv) = 0
　　　　　　lv = lv - 1
　　　　　　n = x(lv) + 1
　　　　Else
　　　　　　x(lv) = n
　　　　　　buf(lv) = v(n)
　　　　　　w(lv) = w(lv - 1) - v(n)
　　　　　　If w(lv) = 0 Then
　　　　　　　　cnt = cnt + 1
　　　　　　　　ret(cnt) = buf
　　　　　　End If
　　　　　　If n = mx Then
　　　　　　　　buf(lv) = Empty
　　　　　　　　w(lv) = 0
　　　　　　　　lv = lv - 1
　　　　　　　　n = x(lv) + 1
　　　　　　Else
　　　　　　　　If w(lv) > 0 Then
　　　　　　　　　　lv = lv + 1
　　　　　　　　End If
　　　　　　　　n = n + 1
　　　　　　End If
　　　　End If
　　Loop Until lv = 0

　　ReDim Preserve ret(1 To cnt)
　　ret = Application.Transpose(Application.Transpose(ret))
　　With ActiveSheet.Range("D1").CurrentRegion
　　　　.ClearContents
　　　　.Resize(UBound(ret, 1), UBound(ret, 2)).Value = ret
　　End With

　　Erase w, x, buf, vSum, ret
　　Debug.Print cnt, timeGetTime - tChk
End Sub

#本スレを汚したくなかったのでこっちに書いちゃいました :D

昨日の投稿とちょうどニアミスになって見落としてしまいました。
遅レス陳謝。

■>qa5325755

「お見事」どころか「ぐだぐだ」でした　orz
質問者的にはとっくに解決してるのに、
回答者の方で変にこだわって独り相撲してるという…。

Functionにこだわりすぎたのと、ConvertFormulaの動作を誤解してたのが敗因(?)デス
もともとVBA課題ですし、Subに切り替えてReferenceStyleで対応するのがリーズナブルでしたね。


■>どうもバグな動きが多い

ですね～。バグというより「十分練られてない」感じ？
「全然別のシステムになったのに、一応互換性維持しよう……とはしたけど途中で嫌になった」
みたいな仕様ですよね。　(ーー;)


■>互換性解析レポート

サンクスです。<(_ _)>

…ぐはっ、ますます混乱してきた　o ....rz
「立ち入り禁止地区」認定w

　#　2000⇒2002で大きく変わった「保護」周りも
　#　「立ち入り禁止地区」認定したままだったり(ぇ

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

■>テキストベースで

（回答者的には？）これ結構重要ですよね。

ブックそのものを配布できない状況で
「こういうユーザフォーム作れ」なんて言っても絶対トラブりますもんね。

わたしが無理矢理気味な一発数式回答だすのも
「テキストベースで確実に伝わるアプローチ」としてですし…。

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

　#　蜂の巣とか
　#　「ちっちゃい物がズラッと並んで個別にウジャウジャ動く」のって
　#　生理的に駄目なんですよね。

>..地雷を踏んで見事撃沈されたような..

■VBA 条件付書式の条件にあっているか
http://bekkoame.okwave.jp/qa5325755.html

これはBAで、お見事なレスでしたから、この関連でプロフに書かれていた事あたりでしょうか。
「自セル」の問題でしたっけ。
セルFunctionでは使えないですけど、Application.ReferenceStyleを弄くると良いみたいですね。

『条件付書式による色をVBAから取得するには？』
http://www.keep-on.com/excelyou/2000lng4/200005/00050350.txt

あと、これは~には書いてませんが
『Excel2007条件付き書式 互換性解析レポート』
p://www.mhl.janis.or.jp/~winarrow/psoft/fcc/formatcondition1.htm
よくmougで回答されてるwinarrowさんのページです。
私はあまり詳しく検証してないので正しいかどうか不明ですが参考まで。

どうもバグな動きが多いのでワタシ的にも「鬼門」です :D



>「UserFormをテキストベースで配布する」
ってやつですｗ
他にも試そうとする方がいらっしゃれば、的なニュアンスでした。
「蓮」...ぁー…なんとなくわかるような。私も最初は並べたしｗ

てっきり~と同じだと思ったら…

「UserFormにWebBrowserを20コ配置」するコードなんですね！（遅　orz

こりゃぁわたし向きだぁ　＼(^o^)／

「UserFormをテキストベースで配布する」ってやつですね（違？

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

実際
「WebBrowserってどうやって置くんだっけ？」とか
「UserForm表示するのはどうするんだっけ？」とか(ぇ
そういうあたりで週末ちょっと悩んだので(ぉぃ

生真面目に20個「並べ」たら「蓮」っぽくなって
ちょっと鳥肌立っちゃったりw

…コードよりも、に、ニーズが…　o .....rz

・状況に応じてUserFormを動的に作成する？
・UserFormをテキストベースで配布する？

…あ、「コーディングの効率化」って書いてある　orz

私は全然UserForm使わない…もとい【使えない】人なので(ry

　#　なんか、本サイトで、見るからに初心者さんなのに
　#　「ユーザフォームで」とか言う人みると「ポカーン」としちゃったり。
　#　いや、わたしが極端に不得手なだけなんでしょうけど…。

…いかんな。「向上を志向しない素人」モードに入っちゃってるww

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

別件１　「ジャグ配列」

よく見たら、~の方に記事がありましたね　orz
とりあえず「安心」しました(ぇ

…てか、TransposeもFormulaArrayも知らんかった　o ...rz

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

別件２　「条件式書式」

コチラに書くのもどうかと思ったんですが、ちょっと敷居が高くて(^^;;;;

FormatCondition周りは、
以前全然ちがうレベルで地雷を踏んで見事撃沈されたような
つらく哀しい思い出がありまして…ww

それ以来わたし的に「鬼門」認定です　orz

　#　という以前に、2007の「条件付書式」って
　#　ワークシートレベルでもいまだによく飲み込めてなかったり(ぉ

　~　にも書いてますがUserForm作成コード。

Sub try()
　　Const vbext_ct_MSForm As Long = 3
　　Const mg As Single = 2
　　Const w　As Single = 100
　　Const h　As Single = 20
　　Dim iw　 As Single
　　Dim ih　 As Single
　　Dim y　　As Single
　　Dim i　　As Long

　　With ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
　　　　iw = .Properties("Width") - .Properties("InsideWidth")
　　　　ih = .Properties("Height") - .Properties("InsideHeight")
　　　　.Properties("Width") = iw + mg + w + mg
　　　　.Properties("Height") = ih + mg + w + mg + h + mg
　　　　With .Designer
　　　　　　For i = 1 To 20
　　　　　　　　With .Controls.Add("Shell.Explorer.2")
　　　　　　　　　　.Left = mg
　　　　　　　　　　.Top = mg
　　　　　　　　　　.Width = w
　　　　　　　　　　.Height = w
　　　　　　　　End With
　　　　　　Next
　　　　　　y = mg + w
　　　　　　With .Controls.Add("Forms.CommandButton.1")
　　　　　　　　.Left = mg
　　　　　　　　.Top = mg + y
　　　　　　　　.Width = w
　　　　　　　　.Height = h
　　　　　　End With
　　　　End With
　　End With
End Sub

『VBAプロジェクトオブジェクトモデルへのアクセスを信頼する』必要がありますけど。

なんかずいぶん本格的に……宇宙語になってる　orz

>bekkoameで28ページ20sec

おぉ！

まだ動かしてませんが、私の履歴なら10秒で取れちゃいますね　＼(^o^)／

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

　#　「下書」優先で「叩き台」の方も解読サスペンド中なのでしばらく試せないかも　(T_T)
　#　「休日の楽しみ」にとっときます。　<(_ _)>

　#　「素人による初心者のためのコーディング講座」はとっとと終わらせて
　#　「素人による怪答者のための部分和対策講座」再開しないと…。orz
　#　つか、自信無いこと騙るのって疲れるのよね、正直(ぉぃ

'-------------------------------------------------
Private Sub matchToV(ByVal ret As String, ByVal ac As Long)

　　Dim dic As Object　'Scriping.Dictionary
　　Dim mc1 As Object　'RegExp.Match
　　Dim mc2 As Object　'RegExp.Match
　　Dim flg As Boolean '重複フラグ
　　Dim key As String　'重複チェックkey
　　Dim x　 As Long
　　Dim y　 As Long
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long
　　Dim idx As Long
　　Dim cnt As Long

　　reg.Pattern = "\r\n"
　　ret = reg.Replace(ret, "")
　　reg.Pattern = PTN0
　　ret = reg.Replace(ret, "<>")
　　reg.Pattern = PTN1
　　Set mc1 = reg.Execute(ret)
　　reg.Pattern = PTN2
　　Set mc2 = reg.Execute(ret)
　　Set dic = CreateObject("Scripting.Dictionary")
　　x = 0
　　y = 0
　　k = ac
　　For i = 1 To k
　　　　flg = False
　　　　key = mc2(y).submatches(0)
　　　　y = y + 1
　　　　If dic.exists(key) Then
　　　　　　idx = dic(key)
　　　　　　flg = mc1(x).submatches(0) <> "ベストアンサー"
　　　　Else
　　　　　　cnt = cnt + 1
　　　　　　idx = cnt
　　　　　　dic(key) = idx
　　　　　　buf(idx, 1) = idx
　　　　　　buf(idx, 2) = key
　　　　End If

　　　　If flg Then
　　　　　　x = x + 6
　　　　Else
　　　　　　For j = 3 To CX
　　　　　　　　buf(idx, j) = mc1(x).submatches(0)
　　　　　　　　x = x + 1
　　　　　　Next
　　　　End If
　　Next

　　Set mc1 = Nothing
　　Set mc2 = Nothing
　　Set dic = Nothing
End Sub
'-------------------------------------------------
Private Sub UserForm_Activate()
　　Call main
End Sub
'-------------------------------------------------
Private Sub UserForm_Click()
　　escFlg = True
End Sub
'-------------------------------------------------

というわけで、bekkoameで28ページ20secくらいになります。
UserFormにWebBrowserを20コ配置して(ｗ
UserForm_Activateイベントで走らせる感じです。
細かなエラーチェックとシェイプアップはこれから :D

'暫定版1から
'-------------------------------------------------
　　Debug.Print Timer - t
　　t = Timer
　　
　　'読み込みページ数セット
　　ac = CLng(mc(0).submatches(0))
　　pg = (ac - 1) \ 20 + 1
　　If Me.Tag = "a" Then
　　　　page = Application.InputBox("page", , pg, Type:=1)
　　　　If (VarType(page) = vbBoolean) Or (page < 1) Then GoTo exitLine
　　　　If pg > page Then
　　　　　　pg = page
　　　　　　ac = page * 20
　　　　End If
　　End If
　　
　　'配列サイズとLoop数調整
　　ReDim dat(1 To pg) As String
　　If pg > MX Then
　　　　wx = MX
　　Else
　　　　wx = pg
　　End If
　　k = 0

　　'WebBrowserLoop
　　For i = 1 To wx
　　　　'Navigate
　　　　With Me.Controls("WebBrowser" & i)
　　　　　　k = k + 1
　　　　　　sURL(4) = CStr(k)
　　　　　　.Tag = sURL(4)
　　　　　　.Navigate2 Join(sURL, "")
　　　　　　wFlg(i) = True
　　　　End With
　　Next
　　Do Until timeout < Timer
　　　　dFlg = False
　　　　For i = 1 To wx
　　　　　　DoEvents
　　　　　　If escFlg Then GoTo exitLine
　　　　　　'innerHTML取得
　　　　　　With Me.Controls("WebBrowser" & i)
　　　　　　　　If wFlg(i) Then
　　　　　　　　　　If (Not .Busy) And (.ReadyState = READYSTATE_COMPLETE) Then
　　　　　　　　　　　　ret = .Document.body.innerhtml
　　　　　　　　　　　　If InStr(ret, keyW4) > 0 Then
　　　　　　　　　　　　　　p = InStr(ret, keyW3)
　　　　　　　　　　　　　　If p > 0 Then
　　　　　　　　　　　　　　　　ret = Mid$(ret, p + Len(keyW3))
　　　　　　　　　　　　　　　　p = InStr(ret, keyW4)
　　　　　　　　　　　　　　　　dat(CLng(.Tag)) = Left$(ret, p - 1)
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　If k = pg Then
　　　　　　　　　　　　　　　　wFlg(i) = False
　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　k = k + 1
　　　　　　　　　　　　　　　　sURL(4) = CStr(k)
　　　　　　　　　　　　　　　　.Tag = sURL(4)
　　　　　　　　　　　　　　　　.Navigate2 Join(sURL, "")
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　　　'終了チェック
　　　　For i = 1 To wx
　　　　　　If wFlg(i) Then
　　　　　　　　dFlg = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If Not dFlg Then Exit Do
　　Loop

　　Debug.Print Timer - t
　　t = Timer

　　ReDim buf(1 To ac, 1 To CX) As String
　　'RegExpでのデータ分割へ
　　Call matchToV(Join(dat, ""), ac)

　　Debug.Print Timer - t
　　t = Timer

　　With ActiveSheet
　　　　.UsedRange.ClearContents
　　　　.Cells(1).Resize(cnt + 1, CX).Value = v
　　　　.Cells(cnt + 2, 1).Resize(ac, CX).Value = buf
　　End With

exitLine:
　　Erase dat
　　Erase buf
　　Set mc = Nothing
　　Set reg = Nothing
　　Unload Me
　　Debug.Print Timer - (timeout - 100)
End Sub
'-------------------------------------------------

'UserFormモジュール
Option Explicit

Const READYSTATE_COMPLETE As Long = 4
Const MX As Long = 20 'WebBrowser数
Const CX As Long = 8　'データ取得用配列の列サイズ

'エラーor読み込みor位置 判断keyword
Const keyW1 = "非公開に設定されています"
Const keyW2 = "404 Not Found"
Const keyW3 = "<DIV class=ok_lq_qa_list_r>"
Const keyW4 = "<DIV id=paginater_history_answers>"

'RegExp用pattern
Const PTNd = "<SPAN id=answer_count>(\d+)</SPAN>"
Const PTN0 = "質問者：| －日付：| －回答数：|カテゴリ：|" _
　　　　　 & "<STRONG>画像</STRONG>|<STRONG>絵</STRONG>"
Const PTN1 = ">([^<]+)<"
Const PTN2 = "<P class=qat><A href=""([^<]+)"">"

Private escFlg As Boolean 'Cancel用フラグ
Private reg　　As Object　'VBScript.RegExp
Private buf()　As String　'data取得用
'-------------------------------------------------
Private Sub main()

　　Dim sURL(0 To 5)　　　　As String　'URL文字列
　　Dim v(0 To 50, 0 To CX) As String　'書き出し用配列
　　Dim wFlg(1 To MX)　　　 As Boolean 'WebBrowser稼動判定
　　Dim dFlg　　As Boolean 'LoopExit判定用
　　Dim x　　　 As Object　'HTMLelement
　　Dim mc　　　As Object　'RegExp.Match
　　Dim ret　　 As String　'innerHTMLチェック用
　　Dim dat()　 As String　'data取得用
　　Dim i　　　 As Long　　'カウンタ
　　Dim j　　　 As Long　　'カウンタ
　　Dim k　　　 As Long　　'カウンタ
　　Dim p　　　 As Long　　'InStr結果。文字検出位置
　　Dim cnt　　 As Long　　'countup用
　　Dim pg　　　As Long　　'Page数
　　Dim ac　　　As Long　　'回答数
　　Dim wx　　　As Long　　'Loop設定用
　　Dim timeout As Single　'タイムアウト設定
　　Dim uid, page
　　

　　uid = Application.InputBox("userID", , 1037781, Type:=1)
　　If VarType(uid) = vbBoolean Then Exit Sub

　　timeout = Timer + 100
　　
　　Dim t As Single
　　t = Timer

　　'sURL(0) = "http://c.oshiete.goo.ne.jp"
　　sURL(0) = "http://bekkoame.okwave.jp"
　　sURL(1) = "/profile/answer/history/u"
　　sURL(2) = CStr(uid)
　　sURL(3) = ".html?page="
　　sURL(4) = 1
　　sURL(5) = "#tabs"

　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Global = True
　　reg.Pattern = PTNd

　　'■
　　With Me.WebBrowser1
　　　　.Navigate Join(sURL, "")
　　　　'待ち
　　　　While .Busy Or (.ReadyState <> READYSTATE_COMPLETE)
　　　　　　DoEvents
　　　　Wend
　　　　With .Document
　　　　　　'待ち と回答数取得
　　　　　　While (Not dFlg)
　　　　　　　　DoEvents
　　　　　　　　ret = .body.innerhtml
　　　　　　　　If InStr(ret, keyW1) > 0 Then GoTo exitLine
　　　　　　　　If InStr(ret, keyW2) > 0 Then GoTo exitLine
　　　　　　　　Set mc = reg.Execute(ret)
　　　　　　　　dFlg = (mc.Count > 0)
　　　　　　Wend
　　　　　　'ユーザー名
　　　　　　For Each x In .getElementsByTagName("h3")
　　　　　　　　v(cnt, 0) = x.innertext
　　　　　　　　Exit For
　　　　　　Next
　　　　　　'UserForm1.Tagにセットした時だけ有効
　　　　　　If Me.Tag = "a" Then
　　　　　　　　'登録日と自己紹介
　　　　　　　　cnt = 1
　　　　　　　　For Each x In .getElementsByTagName("p")
　　　　　　　　　　If cnt = 2 Then Exit For
　　　　　　　　　　If x.innertext Like "登録日：*" Then
　　　　　　　　　　　　v(cnt, 0) = x.innertext
　　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　v(cnt, 0) = x.innertext
　　　　　　　　'プロフィール。tableタグLoop
　　　　　　　　For Each x In .getElementsByTagName("table")
　　　　　　　　　　If x.classname = "ok_mypage_userdata" Or _
　　　　　　　　　　　 x.classname = "ok_mypage_userprofile" Then
　　　　　　　　　　　　For i = 0 To x.Rows.length - 1
　　　　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　　　　For j = 0 To x.Rows(i).Cells.length - 1
　　　　　　　　　　　　　　　　v(cnt, j) = x.Rows(i).Cells(j).innertext
　　　　　　　　　　　　　　Next
　　　　　　　　　　　　Next
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　End With
　　End With
　　'■以上WebBrowser1だけの処理
'-------------------------------------------------
'暫定版2へ

>質問者さんや【回答者さんに】

wwwww

>#もともとウラワザ路線好きだし :D

ww　わたしも大好きです♪
もともとdeus_ex_machinaですしw

　#　懐かしいな
　#　385738さんとかぶんなきゃずっと使いたかったんだけど…
　#　でも、どちらかと言えばやっぱわたし向きのハンドルだよねw

http://www.excite.co.jp/dictionary/english_japanese/?search=deusexmachina&dictionary=NEW_EJJE&block=36869&offset=1756

>一度自分のスタイル(?)で書き直してみないと、
>イマイチ得心がいかないというか、..
ぁ、同感です。
自分の手を動かして頭も使って、でないと..というのはありますよね。
眺めるだけじゃなくて実際に試さないと。って質問者さんや回答者さんに言いたかったりも。


>"Internet Explorer ではこのページは表示できません"
..ですか。
連続実行時のセキュリティ制限かなんかありましたっけ？
ちょっと現象出ないのであやふやですが。
#なんか誰かが言ってたような？


とりあえず
『反則』技の方針でいってみますか。
#もともとウラワザ路線好きだし :D
どれだけ短縮できるかわかんないですけど。

劣化中ともいう　orz

一度自分のスタイル(?)で書き直してみないと、
イマイチ得心がいかないというか、血肉にならない気がするんですよね。
で、劣化した状態で血肉になるというww　 o ....rz

　　#　.Visible = True　で確認してみたら
　　#　「永久マテ」状態になるケースは応答遅延じゃなくて
　　#　"Internet Explorer ではこのページは表示できません" でした orz

　　#　IE壊れてる？　通信設定がオカシイ？　
　　#　タイムアウト設定してRefreshかけるかなぁ…。

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

■>反則

ぃ、ぃや、わたし的には結構アリなんじゃないかと…(ぇ

　#　素人考えでタブをずらりと並べて
　#　ブラクラ状態になっちゃったのはナイショです(爆

10ページ「待ち」テスト。

bekkoame
8.359375
5.609375
5.859375

ぉお。
って結果だよね。

最初、ieじゃなくてUserForm上のWebBrowserで試してみた。
20sec前後で変わらず...

悔しまぎれに（日本語ちが？
UserFormにWebBrowserコントロールを10個並べてみた。
んんー…アタマ悪すぎ..orz

ieの表示の問題なのかな。
ieオプションで画像表示なしにして
Call sample("1037781", ActiveSheet, 10)
で10ページ取得をテスト。
余計な事せずに単純に「待ち」だけ残して

okwave
41.8125
36.82813
25.70313

oshiete.goo
29.64063
26.875
30.84375

bekkoame
32.48438
18.64063
19.5625

こんな感じです。
bekkoame速いですね。

全履歴と直近10ページと分けて運用する方向がいいのだろうか。
んんー…

okwaveで一括ダウンロードサービスなんかやってくれ
..るわけないよね :P



ieプロセス終了については、取り敢えずありがちな手法だと、WMIを使う方法があります。

Sub ieClose2()
　　Dim colProc As Object
　　Dim Proc　　As Object

　　Set colProc = GetObject("winmgmts:\\.\root\cimv2").ExecQuery( _
　　　　　　　　　　　　　　"Select * from Win32_Process " & _
　　　　　　　　　　　　　　"Where Description=""iexplore.exe""")
　　For Each Proc In colProc
　　　　Proc.Terminate
　　Next
　　
　　Set colProc = Nothing
End Sub

■>ここで練り上げできたらなぁと :D

是非是非練り上げちゃってくださいませ。<(_ _)>

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

■> タスクマネージャから[プロセスの終了]で

…なんですが、iexplore.exe　を終了しても
再起動(?)しちゃうんですよね。

　-----------------------------------
　このタブは回復されました
　このWebページには問題があるため、Internet Explorer はタブを閉じ、【再度開きました】
　-----------------------------------

ってインフォメーションバルーン【だけ】表示されます。

WinXP Pro SP3 ／ IE8.0.6001.18702IC

まぁ、気にしなければいいんですが（ぇ

　#…という以前に、bekkoameはやっぱダメだw
　#普通にブラウザで見てるときだって
　#F5攻撃(ぉ　しないとまともに表示されないんだから…

【今後の（個人的）課題】

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

■>簡易的に

おぉ！　なんと便利なTip！！

なんでWordだけなんでしょうね？
WordはExcelと違ってSDIだからかなぁ？？

しかもコレだと
（タスクマネージャから終了する場合と違って）復活しないみたいデス。

【解決-BA】＼(^o^)／

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

■>デバッグメッセージがカッコ悪かったら

あり？

「待ち」ループ入ってる状態で

　Application.EnableCancelKey = xlErrorHandler

効きます？

「待ち」ループ中でなければ普通にトラップできるんですが
ループ中だと

　-----------------------------------
　実行時エラー18
　ユーザーによる割り込みが発生しました。
　-----------------------------------　

が見え………あーーナルホド！！！

ESCキー長押だと中断されちゃうけど
[Ctrl]+[Break]ならちゃんと捉りますね。

【解決-BA】＼(^o^)／

　#　ちなみに、この件↑の続きで
　#　サバから放置されたときに、ESCでexitLineに流すことができれば
　#　中断してもIEのプロセス残らないよね…という趣旨でした。

う～、[ESC]と[Ctrl]+[Break]の違いってずっと曖昧なままなのよね(ぉぃ　orz

【今後の（個人的）課題】

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

「できなかった」ぢゃなくて
「【何をして】できなかったか」書きましょう　＞　わたし

要領の悪いテスタ(?)でスミマセン　orz
適当にスルーしていただいて構いませんから…ホントに。　orz

　…とりあえず寝よう。

>…って完全に他力本願モードかよっw　＞　わたし
ぃぇ、私も困ってますし。
ここで練り上げできたらなぁと :D

>#　…という以前に、マクロだけ落としちゃってIEのプロセスが残った場合はﾄﾞｳｽﾚﾊﾞ…　orz
ぁ、そうですね。考えなきゃ...
プロセスLoopしてVisible = Trueかな...
とりあえずはタスクマネージャから[プロセスの終了]で(何っｗ

簡易的に
Sub ieClose()
　　With CreateObject("Word.Application")
　　　　If .Tasks.Exists("Internet Explorer") Then
　　　　　　.Tasks("Internet Explorer").Close
　　　　End If
　　　　.Quit
　　End With
End Sub
でもいいかも :D
p://officetanaka.net/excel/vba/tips/tips61.htm

>#　DoEventsでOSに制御が渡ってるときは、ESCキーの割り込みトラップできないのね　orz
ですねー。
とりあえず[esc]キー長押しか[Ctrl]+[Break]で。

デバッグメッセージがカッコ悪かったら
冒頭に
On Error GoTo exitLine
Application.EnableCancelKey = xlErrorHandler

exitLineのとこで
：
exitLine:
　　If Err().Number <> 0 Then
　　　　MsgBox "cancel"
　　End If
　　ie.Quit
：

#[Ctrl]+[Break]がいいかな。

大期待！　＼(^o^)／　

大感謝！　<(_ _)>　

　…って完全に他力本願モードかよっw　＞　わたし

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

しかもRemまで細かくつけてある！！！

大感謝！　<(_ _)>

　…って読まなく…ちゃ…　orz　ww

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

■>速度的にどうも...

５桁ポイント級となるとちと厳しいですが
我々w４桁ポイント級の回答者であれば、十分実用になりますね♪

そもそも対象が回答履歴公開してなけりゃダメなわけですし…。

手元のテストでは

　http://okwave.jp
だと
　・157.43750 sec.
　・142.75000 sec.
　・150.75000 sec.
なのに対して

　http://bekkoame.okwave.jp
だと
　・93.81250 sec.
　・92.03125 sec.
　・100.21880 sec.
でちょっと有利な感じですね。

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

　#　今はどこが一番軽いんだろ？？
　#　つか安定性も大事だよね。
　#　OKWaveは安定してるけど重い／bekkoameは軽いけど時々放置プレイ　(ーー;)

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

以下小声でw

　#　…という以前に、マクロだけ落としちゃってIEのプロセスが残った場合はﾄﾞｳｽﾚﾊﾞ…　orz
　#　DoEventsでOSに制御が渡ってるときは、ESCキーの割り込みトラップできないのね　orz

ふぁいと！　＞　わたし　orz

　　'：（タタキ台1の続き）
　　'-------------------------------------------------
　　Set ie = CreateObject("InternetExplorer.Application")
　　With ie
　　　　'■
　　　　'.Visible = True
　　　　.navigate Join(sURL, "")
　　　　'待ち
　　　　While .busy Or (.readystate <> READYSTATE_COMPLETE)
　　　　　　DoEvents
　　　　Wend
　　　　With .document
　　　　　　'待ち(回答数の読み込み終了待ち)
　　　　　　While InStr(s, keyW1) = 0 And Not flg
　　　　　　　　DoEvents
　　　　　　　　s = .body.innerhtml
　　　　　　　　p = InStr(s, keyW2)
　　　　　　　　flg = IsNumeric(Mid$(s, p + Len(keyW2), 1))
　　　　　　　　If InStr(s, keyW3) > 0 Then GoTo exitLine
　　　　　　Wend
　　　　　　'ユーザー名
　　　　　　For Each x In .getElementsByTagName("h1")
　　　　　　　　v(r, 0) = x.innertext
　　　　　　Next
　　　　　　'登録日と自己紹介
　　　　　　r = 1
　　　　　　For Each x In .getElementsByTagName("p")
　　　　　　　　If r = 2 Then Exit For
　　　　　　　　If x.innertext Like "登録日：*" Then
　　　　　　　　　　v(r, 0) = x.innertext
　　　　　　　　　　r = r + 1
　　　　　　　　End If
　　　　　　Next
　　　　　　v(r, 0) = x.innertext
　　　　　　'プロフィール。tableタグLoop
　　　　　　For Each x In .getElementsByTagName("table")
　　　　　　　　If x.classname = "ok_mypage_userdata" Or _
　　　　　　　　　 x.classname = "ok_mypage_userprofile" Then
　　　　　　　　　　For i = 0 To x.Rows.Length - 1
　　　　　　　　　　　　r = r + 1
　　　　　　　　　　　　For j = 0 To x.Rows(i).Cells.Length - 1
　　　　　　　　　　　　　　v(r, j) = x.Rows(i).Cells(j).innertext
　　　　　　　　　　　　Next
　　　　　　　　　　Next
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　'■以上１ページ目だけの処理
　　　　'見出しセット
　　　　r = r + 2
　　　　j = 0
　　　　For Each tmp In Split("url thema status category questioner time anser")
　　　　　　v(r, j) = tmp
　　　　　　j = j + 1
　　　　Next
　　　　'読み込みページ数セット
　　　　If pg = 0 Then
　　　　　　mx = CLng(Mid$(v(4, 2), 5))
　　　　　　pg = (mx - 1) \ 20 + 1
　　　　End If
　　　　'設定ページLoop
　　　　For i = 1 To pg
　　　　　　sURL(3) = i
　　　　　　.navigate Join(sURL, "")
　　　　　　While .busy Or (.readystate <> READYSTATE_COMPLETE)
　　　　　　　　DoEvents
　　　　　　Wend
　　　　　　With .document
　　　　　　　　'待ち(回答履歴全表示まで)
　　　　　　　　While InStr(.body.innertext, keyW1) = 0
　　　　　　　　　　DoEvents
　　　　　　　　Wend
　　　　　　　　'書き込み位置一時記憶rr
　　　　　　　　rr = r
　　　　　　　　'PタグLoop
　　　　　　　　For Each x In .getElementsByTagName("p")
　　　　　　　　　　If x.classname = "qat" Then
　　　　　　　　　　　　r = r + 1
　　　　　　　　　　　　v(r, 0) = Mid$(x.innerhtml, 10, 33)
　　　　　　　　　　　　v(r, 1) = x.innertext
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　'書き込み位置rrに戻る
　　　　　　　　r = rr
　　　　　　　　'DIVタグLoop
　　　　　　　　For Each x In .getElementsByTagName("DIV")
　　　　　　　　　　'classNameで判断
　　　　　　　　　　If x.classname Like "icon_answer_*" Then
　　　　　　　　　　　　r = r + 1
　　　　　　　　　　　　v(r, 2) = x.innertext
　　　　　　　　　　ElseIf x.classname = "ico_cate_list on_gry clearfix" Then
　　　　　　　　　　　　buf = Split(x.innertext, vbCrLf)
　　　　　　　　　　　　v(r, 3) = buf(1)
　　　　　　　　　　　　buf = Split(buf(0), "－")
　　　　　　　　　　　　v(r, 4) = buf(0)
　　　　　　　　　　　　v(r, 5) = buf(1)
　　　　　　　　　　　　v(r, 6) = buf(2)
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End With
　　　　Next
　　End With
　　'シート書き出し
　　With ws
　　　　.UsedRange.ClearContents
　　　　.Cells(1).Resize(r + 1, 7).Value = v
　　End With

exitLine:
　　ie.Quit
　　Set x = Nothing
　　Set ie = Nothing
　　'MsgBox "finish"
End Sub

まずは、取りあえず全回答リスト取得で。
重複除外はそのうちに。

Option Explicit
'-------------------------------------------------
Sub test()
　　Dim t As Single

　　t = Timer
　　Call sample("1037781", ActiveSheet) ', 1)
　　Debug.Print Timer - t
End Sub
'-------------------------------------------------
'Uid:ユーザーid,　ws:書き出しシート,　pg:読み込みページ数
Sub sample(ByVal Uid As String, _
　　　　　 ByRef ws As Worksheet, _
　　　　　 Optional ByVal pg As Long)
　　　　　
　　Const READYSTATE_COMPLETE As Long = 4
　　Const keyW1 = "次へ>>"
　　Const keyW2 = "<SPAN id=answer_count>"
　　Const keyW3 = "非公開に設定されています"
　　
　　Dim ie　　As Object　　　　　　　　 '"InternetExplorer.Application"
　　Dim x　　 As Object　　　　　　　　 'HTMLelement
　　Dim flg　 As Boolean　　　　　　　　'回答数読み込みチェック
　　Dim mx　　As Long　　　　　　　　　 '回答数
　　Dim p　　 As Long　　　　　　　　　 'InStr結果。文字検出位置
　　Dim r　　 As Long　　　　　　　　　 '配列行位置
　　Dim rr　　As Long　　　　　　　　　 '一時記憶位置
　　Dim i　　 As Long　　　　　　　　　 'Loopカウンタ
　　Dim j　　 As Long　　　　　　　　　 'Loopカウンタ
　　Dim s　　 As String　　　　　　　　 'innerHTMLチェック用
　　Dim buf() As String　　　　　　　　 ' Split分割作業用
　　Dim tmp　　　　　　　　　　　　　　 '見出しLoop用
　　Dim sURL(0 To 4)　　　　　As String 'URL文字用
　　Dim v(0 To 20000, 0 To 6) As String '書き出し用配列

　　'URLセット
　　sURL(0) = "http://okwave.jp/profile/answer/history/u"
　　sURL(1) = Uid
　　sURL(2) = ".html?page="
　　sURL(3) = 1
　　sURL(4) = "#tabs"
　　'-------------------------------------------------
　　'：（タタキ台2に続く）