■「条件付き書式の設定」で赤色に設定された数値も検索

条件付き書式で現れた「結果」(セルが赤く塗られた，フォントの書式が変わった，など）を検索したり検出する方法は，..
マクロを使って出来なくもない..。（xl2003環境）

Option Explicit
'-----------------------------------------------------------
Sub prep() '準備。Bookを追加しSheet1のA1:A50に条件付き書式を設定。
　　With Workbooks.Add(xlWBATWorksheet).Sheets(1).Range("A1:A50")
　　　　.FormulaR1C1 = "=INT(RAND()*20)+1"
　　　　.Value = .Value
　　　　.FormatConditions.Add(Type:=xlCellValue, _
　　　　　　　　　　　　　　　Operator:=xlBetween, _
　　　　　　　　　　　　　　　Formula1:="5", _
　　　　　　　　　　　　　　　Formula2:="10").Font.Color = vbRed
　　End With
End Sub
'-----------------------------------------------------------
Sub test() 'prep後BookをActiveにして実行。
　　Dim ws　As Worksheet
　　Dim tmp As String
　　Dim buf As String
　　Dim n　 As Long
　　Dim r　 As Range
　　
　　Application.ScreenUpdating = False
　　'作業用mhtファイル名を設定。 _
　　 同名既存ファイルがあれば上書きするので注意。
　　tmp = Application.DefaultFilePath & "\temp.mht"
　　Set ws = ActiveSheet
　　ActiveWorkbook.PublishObjects.Add( _
　　　　　　xlSourceSheet, tmp, _
　　　　　　ws.Name, "", _
　　　　　　xlHtmlStatic).Publish True
　　
　　'作業用mhtファイルOpen。
　　n = FreeFile
　　Open tmp For Input As #n
　　buf = StrConv(InputB(LOF(n), #n), vbUnicode)
　　Close #n

　　'---置換作業---
　　'途中改行があれば削除。
　　buf = Replace$(buf, "=" & vbCrLf, "")
　　'とにかく"ignore:"を消せばいいかな。
　　buf = Replace$(buf, "mso-ignore:", "")
　　'--------------
　　
　　'作業ファイル書き込み直してOpen、検索作業。
　　n = FreeFile
　　Open tmp For Output As #n
　　Print #n, buf
　　Close #n
　　
　　With Application.FindFormat
　　　　.Clear
　　　　.Font.Color = vbRed
　　End With
　　
　　With Workbooks.Open(tmp)
　　　　With .Sheets(1).UsedRange
　　　　　　.Replace What:="*", _
　　　　　　　　　　 Replacement:="#n/a", _
　　　　　　　　　　 LookAt:=xlPart, _
　　　　　　　　　　 SearchFormat:=True
　　　　　　On Error Resume Next
　　　　　　Set r = .SpecialCells(xlCellTypeConstants, xlErrors)
　　　　　　On Error GoTo 0
　　　　End With
　　　　If Not r Is Nothing Then
　　　　　　ws.Activate
　　　　　　ws.Range(r.Address(0, 0)).Select
　　　　End If
　　　　.Close False
　　End With
　　'作業用mhtファイル削除。
　　Kill tmp
　　Set r = Nothing
　　Set ws = Nothing
　　Application.ScreenUpdating = True
End Sub

■VBA Replace(buf, "ignore:", "")で既出。scrap重ねですorz

ついでに
■RegisterClipboardFormatA("HTML Format")の使い回しでhttp://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=70352;id=excel

■VBA Replace(buf, "ignore:", "")

#しつこいようだが (:
『条件付き書式で設定された書式を残して、条件付き書式を解除する』手法として
■xl2007：条件付き書式の色設定だけ残す
ver2007以降はPublishObjectオブジェクトが使える。

■xl2003：条件付き書式の色設定だけ残す
ver2003以前はWordを経由して取れる。

■RegisterClipboardFormatA("HTML Format")
Win32APIを使ってClipboardから"HTML Format"を取ればver共通で可能。

...など書いてきました。
関連でもう一つ。
2003でも[PublishObjects.Addメソッド]を使って、WinAPIを使わずExcelの機能だけで可能だったのでした。

'条件付き書式を設定したActiveSheetに対して処理。
Sub test()
　　Dim ws　As Worksheet
　　Dim tmp As String
　　Dim buf As String
　　Dim n　 As Long

　　'作業用mhtファイル名を設定。 _
　　 同名既存ファイルがあれば上書きするので要注意。
　　tmp = Application.DefaultFilePath & "\temp.mht"
　　Set ws = ActiveSheet
　　ActiveWorkbook.PublishObjects.Add( _
　　　　　　xlSourceSheet, tmp, _
　　　　　　ws.Name, "", _
　　　　　　xlHtmlStatic).Publish True

　　'作業用mhtファイルOpen。
　　n = FreeFile
　　Open tmp For Input As #n
　　buf = StrConv(InputB(LOF(n), #n), vbUnicode)
　　Close #n

　　'---置換作業---
　　'途中改行があれば削除。
　　buf = Replace$(buf, "=" & vbCrLf, "")
　　'とにかく"ignore:"を消せばいいみたい。
　　buf = Replace$(buf, "mso-ignore:", "")
　　'--------------

　　'作業ファイル書き込み直してOpen、Copy。
　　n = FreeFile
　　Open tmp For Output As #n
　　Print #n, buf
　　Close #n
　　With Workbooks.Open(tmp)
　　　　.Sheets(1).Copy ws
　　　　.Close False
　　End With
　　'コピー追加したシートの値クリア。
　　ActiveSheet.UsedRange.ClearContents
　　'作業用mhtファイル削除。
　　Kill tmp
　　Set ws = Nothing
End Sub

#一応Ver.2000,2003,2007,2010で動作確認。（winXP）

■RegisterClipboardFormatA("HTML Format")

'標準Module
'参照設定:【Microsoft Forms 2.0 Object Library】
Option Explicit
Option Private Module

Declare Function CloseClipboard Lib "user32.dll" () As Long

Declare Function OpenClipboard Lib "user32.dll" ( _
　　　　　　　　　　　　　　　 ByVal hwnd As Long) As Long

Declare Function GetClipboardData Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　　ByVal wFormat As Long) As Long

Declare Function RegisterClipboardFormatA Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　　　　　　ByVal lpszFormat As String) As Long

Declare Function GlobalSize Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Function GlobalLock Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
　　　　　　　　　　　　　ByVal hpvDest As Any, _
　　　　　　　　　　　　　ByVal hpvSource As Any, _
　　　　　　　　　　　　　ByVal cbCopy As Long)
'-------------------------------------------------
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
　　　　chk .Cells
　　　　Stop
　　　　test .Cells
　　　　chk .Cells
　　End With
End Sub
'-------------------------------------------------
Sub test(r As Range)
　　Dim buf As String
　　Dim mem As Long
　　Dim sz　As Long
　　Dim lk　As Long

　　r.Copy
　　OpenClipboard 0&
　　mem = GetClipboardData(RegisterClipboardFormatA("HTML Format"))
　　CloseClipboard
　　If mem = 0 Then Exit Sub
　　sz = GlobalSize(mem)
　　lk = GlobalLock(mem)
　　buf = String(sz + 1, vbNullChar)
　　RtlMoveMemory buf, lk, sz
　　GlobalUnlock mem
　　buf = Left$(buf, InStr(buf, vbNullChar) - 1)
　　buf = Replace$(buf, "mso-ignore:style;", "") '■2007,2010では無くてもOK
　　With New DataObject
　　　　.Clear
　　　　.SetText buf
　　　　.PutInClipboard
　　End With
　　r.Worksheet.Paste r
End Sub
'-------------------------------------------------
Sub chk(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

#『条件付き書式の色設定だけ残す』..また？..orz
#一応Ver.2000,2003,2007,2010で動作確認。（winXP）
#でもWin32APIについての理解はも浅い私ですから
#試す場合は自己責任でお願いします。

#参考にさせて頂いたサイト
http://homepage2.nifty.com/kmado/kvba.htm（E03M121）
http://www.tsware.jp/study/vol1/kaibo_15.htm

■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を回すよりちょっと速い。
もうちょっとコード整理したいと思いつつもまぁ..動いてるからいいか、なんて :(