■xl2003：条件付き書式の色設定だけ残す

■xl2007：条件付き書式の色設定だけ残す では[PublishObjects.Addメソッド]を使っていますが、これは2003以前では無効です。
最後に
>他に、Wordを経由させる手法でも書式が固定されて取得できるようです。これは2003以前も共通でいけるような気がしますね。
>：
>機会あったらこちらを試行してもいいかも。
..と書いてるように、Word経由を試してみました。

前記事と同じで、まずはシートを追加し、条件付き書式を設定するコード。

Option Explicit

Sub pre()
　　With Sheets.Add.Range("B5:D10")
　　　　.Formula = "=INT(RAND()*100)"
　　　　.Value = .Value
　　　　With .FormatConditions
　　　　　　.Delete
　　　　　　.Add(xlCellValue, xlLess, 40).Interior.ColorIndex = 46
　　　　　　.Add(xlCellValue, xlLess, 80).Interior.ColorIndex = 45
　　　　　　.Add(xlCellValue, xlGreaterEqual, 80).Interior.ColorIndex = 44
　　　　End With
　　　　Call try(.Cells)
　　End With
End Sub
'-------------------------------------------------
Sub try(ByRef r As Range)
　　Dim rg As Range
　　Dim x　As Long
　　Dim y　As Long
　　Dim i　As Long

　　Set rg = r.Offset(, r.Columns.Count + 1).Item(1)
　　For x = 1 To r.Columns.Count
　　　　For y = 1 To r.Rows.Count
　　　　　　With rg.Offset(i)
　　　　　　　　.Value = r(y, x).Address(0, 0)
　　　　　　　　.Offset(, 1).Value = r(y, x).Value
　　　　　　　　.Offset(, 2).Value = r(y, x).Interior.Color
　　　　　　　　.Offset(, 3).Interior.Color = .Offset(, 2).Value
　　　　　　　　i = i + 1
　　　　　　End With
　　　　Next
　　Next
　　Set rg = Nothing
End Sub

"word.application"を経由して、表示された色だけ残し条件付き書式を解除するコード。

Sub test()
　　Dim wd As Object
　　Dim r　As Range

　　Set r = ActiveSheet.Range("B5:D10")
　　r.Item(1).Select
　　Set wd = CreateObject("word.application")
　　'wd.Visible = True
　　With wd.documents.Add
　　　　r.Copy
　　　　.content.pasteexceltable False, False, False
　　　　.tables(1).Range.Copy
　　　　r.Worksheet.PasteSpecial "HTML"
　　　　.Close False
　　End With
　　wd.Quit
　　Call try(r)

　　Set r = Nothing
　　Set wd = Nothing
End Sub

（結果）

一応、取れてるようです。
#ただし色をカスタマイズしてる場合は正確には取れないみたい :(

■続々）ADOのメモリリーク

そう言えばずっと気になってて検証せねばと思いつつ忘れてた。
リンクを貼って頂いてた『守破離でいこう!!』様の記事にMicrosoft.ACE.OLEDB.12.0プロバイダを使うとメモリリークしないというコメントがあったのだった。
WinXP/Excel2003の環境に、[2007 Office system ドライバ: データ接続コンポーネント]をダウンロードして試してみた。
（Office2007インストール済み環境では不要）
手順は
・新規Book作成、名前をつけて保存。
・過去記事の Private Sub test_PRE()を新規Bookにコピーして実行。
・以下コードコピーして Sub memLeaktest() 実行。
・■TESTプロシージャ 箇所で ADOtest1 と ADOtest2 をそれぞれ試行してみる。

Option Explicit
'Performance monitor functions for Visual Basic from PDH.DLL
Private Declare Function PdhVbOpenQuery _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByRef QueryHandle As Long) As Long
Private Declare Function PdhCloseQuery _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbAddCounter _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long, _
　　　　　　　　　　　　　　　ByVal CounterPath As String, _
　　　　　　　　　　　　　　　ByRef CounterHandle As Long) As Long
Private Declare Function PdhRemoveCounter _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal CounterHandle As Long) As Long
Private Declare Function PdhCollectQueryData _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal CounterHandle As Long, _
　　　　　　　　　　　　　　　ByRef CounterStatus As Long) As Double
'-------------------------------------------------
Sub memLeaktest()
　　Const tx As Long = 30 'テスト回数
　　Const wkSQL = "SELECT * FROM [data$]"
　　Const cPath = "¥Process(Excel)¥Private Bytes"
　　Dim ws　　　As Worksheet
　　Dim rng　　 As Range
　　Dim wkBook　As String
　　Dim hPDHQry As Long　 'Handle to performance monitor query
　　Dim hPDHCnt As Long　 'Handle to performance monitor counter
　　Dim cStat　 As Long　 'Status of counter when checked
　　Dim pByts　 As Double 'Value of counter when checked
　　Dim x　　　 As Long
　　Dim i　　　 As Long
　　Dim ret(0 To tx)

　　With ThisWorkbook
　　　　Set ws = .Sheets("out")
　　　　Set rng = .Sheets("data").Range("A2")
　　　　wkBook = .FullName
　　End With
　　x = PdhVbOpenQuery(hPDHQry)
　　x = PdhVbAddCounter(hPDHQry, cPath, hPDHCnt)
　　x = PdhCollectQueryData(hPDHQry)
　　pByts = PdhVbGetDoubleCounterValue(hPDHCnt, cStat)
　　If cStat = 0 Then
　　　　ret(0) = CLng(pByts) ¥ 1024
　　End If

　　For i = 1 To tx
　　　　rng.Value = "'" & i

　　　　'■TESTプロシージャ
　　　　Call ADOtest1(ws, wkBook, wkSQL)

　　　　x = PdhCollectQueryData(hPDHQry)
　　　　pByts = PdhVbGetDoubleCounterValue(hPDHCnt, cStat)
　　　　If cStat = 0 Then
　　　　　　ret(i) = CLng(pByts) ¥ 1024
　　　　End If
　　　　'念のため更新されている事の確認用
　　　　'Debug.Print ws.Cells(1).Value
　　Next

　　x = PdhRemoveCounter(hPDHCnt)
　　x = PdhCloseQuery(hPDHQry)
　　ThisWorkbook.Sheets("chk").Range("IV2").End(xlToLeft) _
　　　　　　　　.Offset(, 1).Resize(tx + 1).Value _
　　　　　　　　= Application.Transpose(ret)

　　Set rng = Nothing
　　Set ws = Nothing
End Sub
'-------------------------------------------------
Sub ADOtest1(ByRef ws As Worksheet, _
　　　　　　ByVal wkBook As String, _
　　　　　　ByVal wkSQL As String)
　　Dim wkCon As Object 'ADODB.Connection
　　Dim wkRst As Object 'ADODB.Recordset

　　On Error GoTo conErr
　　ws.UsedRange.ClearContents
　　Set wkCon = CreateObject("ADODB.Connection")
　　With wkCon
　　　　.Provider = "Microsoft.Jet.OLEDB.4.0"
　　　　.Properties("Extended Properties") = "Excel 8.0"
　　　　.Properties("Data Source") = wkBook
　　　　.Open
　　End With
　　On Error GoTo rsErr
　　Set wkRst = CreateObject("ADODB.Recordset")
　　wkRst.Open wkSQL, wkCon
　　ws.Range("A1").CopyFromRecordset wkRst
　　wkRst.Close
rsErr:
　　wkCon.Close
conErr:
　　Set wkRst = Nothing
　　Set wkCon = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub
'-------------------------------------------------
Sub ADOtest2(ByRef ws As Worksheet, _
　　　　　　 ByVal wkBook As String, _
　　　　　　 ByVal wkSQL As String)
　　Dim wkCon As Object 'ADODB.Connection
　　Dim wkRst As Object 'ADODB.Recordset

　　On Error GoTo conErr
　　ws.UsedRange.ClearContents
　　Set wkCon = CreateObject("ADODB.Connection")
　　With wkCon
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　.Properties("Extended Properties") = "Excel 12.0"
　　　　.Properties("Data Source") = wkBook
　　　　.Open
　　End With
　　On Error GoTo rsErr
　　Set wkRst = CreateObject("ADODB.Recordset")
　　wkRst.Open wkSQL, wkCon
　　ws.Range("A1").CopyFromRecordset wkRst
　　wkRst.Close
rsErr:
　　wkCon.Close
conErr:
　　Set wkRst = Nothing
　　Set wkCon = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub

結果です。（テスト間はExcel再起動）

確かにメモリリークは解消されてるようです。

■VBA XMLHTTP.responseText

#昨日のおまけみたいなもので
昨日のコードで作成されるシートのB列、http://oshiete.goo.ne.jp..URLアドレス文字列を選択して実行。
Q&Aページを簡易的に閲覧します。

Sub try()
　　Const PTN = ">([^<>]+)<"
　　Const CK0 = "<div class=""q-title"">"
　　Const CK1 = "<!-- google_ad_section_end(name=s1) -->"
　　Dim msx　As Object 'MSXML2.ServerXMLHTTP
　　Dim reg　As Object 'VBScript.RegExp
　　Dim mc　 As Object 'RegExp.Matches
　　Dim m　　As Object 'RegExp.Matches.SubMatches
　　Dim sUrL As String 'URLアドレス(ActiveCell.Value)
　　Dim ret　As String 'responsetext
　　Dim tmp　As String
　　Dim v()　As String
　　Dim n　　As Long
　　Dim i　　As Long
　　Dim flg　As Boolean

　　sUrL = ActiveCell.Value & "?order=asc"
　　If Not sUrL Like "http://oshiete.goo.ne.jp*" Then
　　　　MsgBox "select error": Exit Sub
　　End If

　　On Error Resume Next
　　Set msx = CreateObject("MSXML2.ServerXMLHTTP")
　　On Error GoTo 0
　　If msx Is Nothing Then
　　　　MsgBox "xlm error": Exit Sub
　　End If

　　On Error GoTo exitLine
　　msx.Open "GET", sUrL, False
　　msx.Send
　　If (msx.Status >= 200) And (msx.Status < 300) Then
　　　　ret = msx.responseText
　　　　n = InStr(ret, CK0)
　　　　If n > 0 Then
　　　　　　ret = Mid$(ret, n)
　　　　　　n = InStrRev(ret, CK1)
　　　　　　If n > 0 Then
　　　　　　　　ret = Left$(ret, n)
　　　　　　　　Set reg = CreateObject("VBScript.RegExp")
　　　　　　　　reg.Global = True
　　　　　　　　reg.Pattern = "<span>"
　　　　　　　　ret = reg.Replace(ret, vbLf)
　　　　　　　　reg.Pattern = PTN
　　　　　　　　Set mc = reg.Execute(ret)
　　　　　　　　If mc.Count > 0 Then
　　　　　　　　　　ReDim v(0 To mc.Count)
　　　　　　　　　　i = 0
　　　　　　　　　　reg.Pattern = "[^\s\n\r]"
　　　　　　　　　　For Each m In mc
　　　　　　　　　　　　tmp = m.submatches(0)
　　　　　　　　　　　　If Not reg.test(tmp) Then
　　　　　　　　　　　　　　tmp = Replace$(tmp, " ", "")
　　　　　　　　　　　　End If
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　v(i) = tmp
　　　　　　　　　　Next
　　　　　　　　　　ret = Join(v, "")
　　　　　　　　　　'文字参照置換
　　　　　　　　　　reg.Pattern = "&quot;"
　　　　　　　　　　ret = reg.Replace(ret, """")
　　　　　　　　　　reg.Pattern = "&gt;"
　　　　　　　　　　ret = reg.Replace(ret, ">")
　　　　　　　　　　reg.Pattern = "&lt;"
　　　　　　　　　　ret = reg.Replace(ret, "<")
　　　　　　　　　　reg.Pattern = "&amp;"
　　　　　　　　　　ret = reg.Replace(ret, "&")
　　　　　　　　　　reg.Pattern = "\n+"
　　　　　　　　　　ret = reg.Replace(ret, vbLf)
　　　　　　　　　　Debug.Print ret
　　　　　　　　　　'実際にはUserForm.TextBoxなどに表示
　　　　　　　　　　'With UserForm1.TextBox1
　　　　　　　　　　'　　.Text = ret
　　　　　　　　　　'　　.SelStart = 0
　　　　　　　　　　'　　.SetFocus
　　　　　　　　　　'End With
　　　　　　　　　　'UserForm1.Show 0
　　　　　　　　　　flg = True
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　End If

exitLine:
　　Erase v
　　Set mc = Nothing
　　Set reg = Nothing
　　Set msx = Nothing
　　If Not flg Then
　　　　With Err()
　　　　　　If .Number = 0 Then
　　　　　　　　ret = "NG"
　　　　　　Else
　　　　　　　　ret = .Number & "::" & .Description
　　　　　　End If
　　　　End With
　　　　MsgBox ret
　　End If
End Sub

#正規表現（は|も）勉強不足です..すみませんorz

#2010.12.09修正
'文字参照置換のところ修正しました。
>reg.Pattern = "&"
>ret = reg.Replace(ret, "&")
ってなんのことやら...orz

#2010.12.20こっそり修正
#"&amp;"の置換はアトよね...orz

■VBA c.oshiete.goo.ne.jp/profile/answer/history

昨日のネタフリでできたUserFormに以下。

'UserForm Module
Option Explicit

Private Const READYSTATE_COMPLETE As Long = 4
Private Const MX As Long = 10 '使用するWebBrowser数
Private Const cx As Long = 8　'データ取得用配列の列サイズ
'エラーor読み込みor位置 判断keyword
Private Const keyW1 = "非公開に設定されています"
Private Const keyW2 = "404 Not Found"
Private Const keyW3 = "<DIV class=ok_lq_qa_list_r>"
Private Const keyW4 = "<DIV id=paginater_history_answers>"
'RegExp用pattern
Private Const PTNd = "<SPAN id=answer_count>(\d+)</SPAN>"
Private Const PTN0 = "質問者：| －日付：| －回答数：|カテゴリ：|" _
　　　　　　　　　 & "<STRONG>画像</STRONG>|<STRONG>絵</STRONG>"
Private Const PTN1 = ">([^<]+)<"
Private 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
　　
　　On Error GoTo exitLine
　　
　　timeout = Timer + 100 'タイムアウト設定
　　'If MsgBox("Activesheetに書き出します。OK?", vbOKCancel) = vbNo Then Exit Sub
　　'回答者ユーザー№
　　uid = 510433 'Application.InputBox("user№", , xxxxxxx, type:=1)
　　If VarType(uid) = vbBoolean Then Exit Sub

　　'sUrL(0) = "http://bekkoame.okwave.jp"
　　sUrL(0) = "http://c.oshiete.goo.ne.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

　　'WebBrowser1を使って回答数などの基本情報取得
　　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に文字"a"をセットした時だけ有効
　　　　　　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
　　　　　　　　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

　　'読み込みページ数をセット
　　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
　　'読み込み終わったWebBrowserから順次、次のページ読み込み
　　Do
　　　　dFlg = False
　　　　For i = 1 To wx
　　　　　　DoEvents
　　　　　　If escFlg Then GoTo exitLine
　　　　　　If timeout < Timer 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

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

　　With Sheets.Add '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
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & "::" & .Description
　　　　End If
　　End With
　　Debug.Print Timer - (timeout - 100)
End Sub
'-------------------------------------------------
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 CommandButton1_Click()
　　escFlg = True
End Sub
'-------------------------------------------------
Private Sub UserForm_Activate()
　　Call main
End Sub

With UserForm1
　　.Tag = ""
　　.Show
End With
や
With UserForm1
　　.Tag = "a"
　　.Show
End With
などとやって呼び出し。

使えなくなった■教えて！gooユーザープロフィール取得コードの代替。
１コのWebBrowserControlを回すよりちょっと速い。
もうちょっとコード整理したいと思いつつもまぁ..動いてるからいいか、なんて :(

■VBA VBComponents.Add(vbext_ct_MSForm)

#しつこいようだけど
[Visual Basic プロジェクトへのアクセスを信頼する]必要あり。

Sub try() '「WebBrowserを20コ配置したUserFormを作成」するコード
　　Const vbext_ct_MSForm As Long = 3
　　Const mgn As Single = 2　 '調整余白
　　Const w　 As Single = 100 'WebBrowser.Width|Height
　　Const h　 As Single = 20　'CommandButton.Height
　　Dim iw　　As Single
　　Dim ih　　As Single
　　Dim i　　 As Long

　　On Error GoTo extLine
　　With ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
　　　　iw = .Properties("Width") - .Properties("InsideWidth")
　　　　ih = .Properties("Height") - .Properties("InsideHeight")
　　　　.Properties("Width") = iw + mgn + w + mgn
　　　　.Properties("Height") = ih + mgn + w + mgn + h + mgn
　　　　With .Designer.Controls
　　　　　　For i = 1 To 20
　　　　　　　　With .Add("Shell.Explorer.2")
　　　　　　　　　　.Left = mgn
　　　　　　　　　　.Top = mgn
　　　　　　　　　　.Width = w
　　　　　　　　　　.Height = w
　　　　　　　　End With
　　　　　　Next
　　　　　　With .Add("Forms.CommandButton.1")
　　　　　　　　.Left = mgn
　　　　　　　　.Top = mgn + w + mgn
　　　　　　　　.Width = w
　　　　　　　　.Height = h
　　　　　　End With
　　　　End With
　　End With

extLine:
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & "::" & .Description
　　　　End If
　　End With
End Sub

■UserForm作成コードで既出。
#一応、次回記事のネタフリで :D