エクセルVBAの実行時エラー

先日からこちらでいろいろ教えていただき、以下を行うマクロを書きました。

R列とY列の2行目以下（行数は不定、ただしA列の行数に一致します。）の各セルにかなり長文の文字列があります。
短いので50文字程度、長いのは1000文字を超えます。
この各セルを、Range("AG1:CG1,CN1:DF1") の検索語句リストに記載の文字列で検索をかけます。
同一セル内に同じ検索文字列が複数ある場合もありますし、どの検索文字列も存在しないセルもあります。
ヒットしたら、該当の検索対象セルと該当の検索語句がある検索語句リストのセルを薄黄色に着色します。
その際、該当の検索対象セルと同一行、かつ該当の検索語句がある検索語句リストのセルと同一列のセルに＋１をして出現数をカウントします。
ヒットしたら、該当の検索対象セル内の検索語句を着色し、太字にします。
着色は検索語句リストのRange("CN1")より右の語句でヒットした場合は青、そうでなければ赤です。.

私にはかなり複雑でしたが、なんとか完成しました。
エクセル2003でためしたところちゃんと動いてくれました。
ところが、同じデータをエクセル2000でためしたところ、最初の何回かはうまくいったのですが、その後

「実行時エラー’-2147417848 (80010108)':
'Font' メソッドは失敗しました:　'Characters'　オブジェクト

というエラーが出るようになりました。（エラーにならない場合もあります。）
同じデータで試しているのにエラーが出たときに検索しているセルは一定ではありませんし、検索語句もまちまちです。
しかも、一旦エラーが発生すると、エクセルのセルが選択できなくなります。（スクロールはできます。）
おまけにファイルの終了はできますが、エクセル自体が終了できなくなり、タスクマネージャでエクセル終了させなくてはなりません。
何がいけないのでしょうか？

Sub Try111012()
Dim tgtC As Range, myWrd As Range, rng As Range, myC As Range
Dim r As Long, pos As Long
Dim t As Single

t = Timer
r = Cells(Rows.Count, "A").End(xlUp).Row '最終行取得
Set tgtC = Range("(R:R,Y:Y) 2:" & r) '検索対象範囲
With tgtC
.Font.ColorIndex = xlAutomatic
.Font.FontStyle = "標準"
.Interior.ColorIndex = xlNone
End With
Range("(AG:DF) 2:" & r).ClearContents 'カウントクリア

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set myWrd = Range("AG1:CG1,CN1:DF1") '検索語句リスト

For Each myC In tgtC '各検索対象セル
flg = Not (flg)
Application.StatusBar = myC.Address(0, 0) & " を検索中" 　'検索セル表示
With myC
For Each rng In myWrd '各検索語句
pos = InStr(1, .Value, rng.Value) '発見位置
If pos > 0 Then 'ヒットしたら
.Interior.ColorIndex = 36 '対象セルを薄黄色に
rng.Interior.ColorIndex = 36 '検索語句セルを薄黄色に
End If
Do While pos > 0 '同じ語句が発見されてるかぎり
With .Characters(pos, Len(rng.Value)).Font 　'ここでエラー！！
.Bold = True '検索語句を太字
.ColorIndex = IIf(rng.Column >= Range("CN1").Column, 5, 3) '着色（赤と青）
End With
Cells(.Row, rng.Column).Value = Cells(.Row, rng.Column).Value + 1 '語句カウント
pos = InStr(pos + 1, .Value, rng.Value) 'セル内検索位置移動
Loop '繰り返し
Next rng '次の検索語句へ
End With
Next myC '次の検索対象セルへ

Range("(CH:CH) 2:" & r).Formula = "=SUM(AG2:CG2)"
Range("(CM:CM) 2:" & r).Formula = "=SUM(CN2:DF2)"
Range("(CJ:CJ) 2:" & r).Formula = "=AND(CH2>0,CM2>0)"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer - t

MsgBox "キーワードを検索して着色しました。" & _
vbNewLine & "出現数も調べました。"
Application.StatusBar = ""
End Sub

No.4 ベストアンサー 回答者： cj_mover 回答日時： 2011/11/11 18:12

回答No.3の続きです。

前述の＜処理４＞の部分だけをWordの書式置換を使って実現するものです。
.PasteSpecial Paste:="HTML"
この一行（２回実行）が際立って時間をとります。
　Office2000 Xp 1.2GHz 256MB
　合致：70（うち一文字の検索語句4）/ 72語
　500行　545188文字、書式置換： 33252件
↑を基準に書きました。
（同一環境でこの３倍くらいのデータ量で１００回位は再起動なしで通りました）
（大量データ向きです。）
' ' ====標準モジュール
Option Explicit
Sub Re7067351wd()
　Dim arrChrColorNum As Variant
　Dim appWD As Object
　Dim rngSrc As Range
　Dim rngWrd As Range
　Dim a As Range, r As Range
　Dim sSngKeys As String
　Dim sTmp As String
　Dim nBtmRow As Long
　Dim i As Long
Dim t As Single
t = Timer

　With Application
　　.ScreenUpdating = False
　　.EnableEvents = False
　　.Calculation = xlCalculationManual
　　.DisplayFormulaBar = False
　End With

　nBtmRow = Cells(Rows.Count, "A").End(xlUp).Row
　Set rngSrc = Range("(R:R,Y:Y) 2:" & nBtmRow)
　Set rngWrd = Range("AG1:CG1,CN1:DF1")

　arrChrColorNum = VBA.Array(Empty, vbRed, vbBlue)

　Set appWD = CreateObject("Word.Application")

　With appWD
　　.DisplayAlerts = 0 'wdAlertsNone
　　With .Options
　　　.CheckSpellingAsYouType = False
　　　.CheckGrammarAsYouType = False
　　End With

　　With .Documents.Add
' ' Wordにコピペ
　　　i = 0
　　　For Each r In rngSrc.Areas
　　　　i = i + 1
　　　　r.Copy
　　　　.Sections(i).Range.PasteSpecial DataType:=2 ' wdPasteText
　　　　Application.CutCopyMode = False
　　　　.Sections.Add ' ExcelのAreasをWordのSectionsに置き換える
　　　Next r

　　　With .Content
'　　　　.Font.Size = 8 ' ←適宜

' ' Wordで書式置換
　　　　With .Find
　　　　　.Forward = True
　　　　　.MatchWildcards = True
'　　　　　.Font.Bold = False ' 太字でない単語だけ検索する場合
　　　　　.Replacement.Font.Bold = True ' 太字（共通）に置換

　　　　　i = 0
　　　　　For Each a In rngWrd.Areas
　　　　　　sSngKeys = "["
　　　　　　i = i + 1
　　　　　　.Replacement.Font.Color = arrChrColorNum(i) ' 赤or青

　　　　　　For Each r In a
　　　　　　　sTmp = r.Value
　　　　　　　If sTmp <> "" Then
　　　　　　　　If Len(sTmp) = 1 Then
　　　　　　　　　sSngKeys = sSngKeys & sTmp
　　　　　　　　Else
　　　　　　　　　.Text = sTmp ' 検索語句
　　　　　　　　　.Execute Replace:=2 ' :=wdReplaceAll' 書式置換実行
　　　　　　　　End If
　　　　　　　End If
　　　　　　Next r

　　　　　　If sSngKeys <> "[" Then
　　　　　　　.Text = sSngKeys & "]" ' 検索語句（一文字単語を正規表現で一括置換）
　　　　　　　.Execute Replace:=2 ' 書式置換実行
　　　　　　End If
　　　　　Next a
　　　　End With ' Content.Find
　　　End With ' Content

' ' WordからExcelにコピペ
　　　i = 0
　　　For Each r In rngSrc.Areas
　　　　i = i + 1
　　　　.Sections(i).Range.Copy
　　　　r(1).PasteSpecial Paste:="HTML"
　　　Next r

　　　.Close False
　　End With ' Document

　　With .Options
　　　.CheckSpellingAsYouType = True
　　　.CheckGrammarAsYouType = True
　　End With
　　.Quit
　End With ' appWD

　With Application
　　.DisplayFormulaBar = True
　　.EnableEvents = True
　　.Calculation = xlCalculationAutomatic
　　.ScreenUpdating = True
　End With
Debug.Print CSng(Timer) - t
　Set appWD = Nothing
　Set rngSrc = Nothing
　Set rngWrd = Nothing
End Sub
' ' ====

Microsoft Web Brouser コントロール （ソースにタグ挿入）を使った例です。
＜処理４＞は行わず（ファイルを軽く保って）
ユーザー操作（右クリック）でWeb Brouser コントロールにマークアップしたテキストを表示する仕様、
ということです。
かなり強引な書き方ですから、実際に使う場合は、別途質問して、私以外の方の回答に頼ってください。
（Tempフォルダの掃除要。UserFormを用いるのがベター。）
Sheet1 に Web Brouser コントロール（WebBrowser1） を挿入しておいた場合の例です。
' ' ====シートモジュール
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
　If Target.Count > 1 Then Exit Sub
　Dim mtxMatch(1 To 2) As Variant
　Dim sTag(1 To 2) As Variant
　Dim v
　Dim s As String
　Dim i
　With WebBrowser1
　　If Target.Column <> 18 And Target.Column <> 25 Then
　　　If .Visible Then
　　　　.Visible = False
　　　　Cancel = True
　　　End If
　　　Exit Sub
　　End If
　　If Target.Value = "" Then Exit Sub
　　s = Target.Value
　　s = Replace(s, vbLf, "<br>")
　　sTag(1) = Split("<b><font color=""red"">,</font color></b>", ",")
　　sTag(2) = Split("<b><font color=""blue"">,</font color></b>", ",")
　　With Range("AG1:CG1,CN1:DF1")
　　　mtxMatch(1) = .Areas(1).Value
　　　mtxMatch(2) = .Areas(2).Value
　　End With
　　For i = 1 To 2
　　　For Each v In mtxMatch(i)
　　　　If InStr(s, v) Then s = Replace(s, v, Join(sTag(i), v))
　　　Next v
　　Next i
　　Erase mtxMatch
　　.Visible = False
　　.Top = Target.Top
　　.Left = Target(1, 2).Left
　　.Document.Clear
　　.Document.Write s
　　.Visible = True
　　.Refresh
　End With
　Cancel = True
End Sub

この回答へのお礼

Sub Re7067351wd()、やってみました。
すごいですね、あまりすごすぎて私の理解がとてもついていけません。
でも正しく作動しました。
有難うございます。

お礼日時：2011/12/14 17:37

No.5 回答者： cj_mover 回答日時： 2011/11/14 09:31

＃あまりにも酷かったので

訂正です。
誤＞Brouser　→Browser
これはスペルミスでした。m<__>m
WebBrowser版のコードも予定と違うものをあげてしまい、
そのままでは意味不明でしょうから再掲します。
　
' ' ====シートモジュール
Option Explicit
　
Private Sub CrWB() ' WebBrowser1 追加、初期設定。一度だけ実行
With OLEObjects.Add(ClassType:="Shell.Explorer.2", Link:=False)
　.Object.GoHome
　.Visible = False
　.Width = 300 ' 適宜
　.Height = 400 ' 適宜
End With
End Sub
　
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim a As Range, r As Range
Dim s As String, arrTagL(1 To 2) As String, sTagR As String
Dim i As Long
　
If Target.Count > 1 Then Exit Sub
If Target.Column <> 18 And Target.Column <> 25 Then
　If WebBrowser1.Visible Then
　　WebBrowser1.Visible = False
　　Cancel = True
　End If
　Exit Sub
End If
If Target.Row = 1 Then Exit Sub
s = Target.Value
If s = "" Then Exit Sub
　
If InStr(s, vbLf) Then s = Replace(s, vbLf, "<br>") ' セル内改行対策
arrTagL(1) = "<b><font color=""red"">" ' 太字、赤
arrTagL(2) = "<b><font color=""blue"">" ' 太字、青
sTagR = "</font color></b>"
For Each a In Range("AG1:CG1,CN1:DF1").Areas
　i = i + 1
　For Each r In a
' ' 赤太字or青太字
　　If InStr(s, r.Value) Then s = Replace(s, r.Value, arrTagL(i) & r.Value & sTagR)
　Next r
Next a
　
With WebBrowser1
　.Visible = False
'　.Document.Clear
　.Refresh
　.Document.Write s
　.Top = Target.Top
　.Left = Target.Left
　.Visible = True
End With
ActiveWindow.ActivePane.ScrollRow = Target.Row
Cancel = True
End Sub
　
' ' ====
　
これ、ソースを書き換えてWebBrowserに表示する例を試してもらって
その可能性だけ解ってもらえれば、、、程度のものです。
（どんな仕様にするかもう一度判断が必要かと思いましたので）
こういうの書いたことない（殆ど知らない私な）ので、
文法的にも正しくない筈ですから、実際に使う場合は、
経験者の知恵が必要になるかと、、、。
検索語は和文ということなので、比較的簡単に実現できるとは思います。
　
そういえば、MS Wordが使える環境かどうかも確認していませんが、
他にも.Charactors.Fontの代りに使えるものはあると思います。
でも
.Charactors.Fontのまま、一度に大量の処理をしない工夫を施すのも
ありかも知れないですね。

この回答へのお礼

なんどもありがとうございます。
高度すぎて私には豚に真珠ですがほんとうに有難うございました。

お礼日時：2011/12/14 17:38

No.3 回答者： cj_mover 回答日時： 2011/11/11 18:00

こんにちは。

だいぶ日が経っていますが一応回答らしきものをあげてみます。

　http://oshiete.goo.ne.jp/qa/7054631.html
　http://oshiete.goo.ne.jp/qa/7058428.html
　このふたつが関連した質問ということでよいでしょうか。

まず処理の内容を整理してみると、
　＜処理１＞検索語句出現数カウント、数値出力
　＜処理２＞検索語句出現数カウント、２群毎の小計及びＡＮＤフラグ（数式出力）
　＜処理３＞検索語句リスト、Ｈｉｔ→背景着色
　＜処理４＞検索対象セル、検索語句Ｍａｔｃｈ→.Charactors.Font.Color
　＜処理５＞検索対象セル、検索語句Ｈｉｔ→背景着色
大別して５つですね。

このうち、質問で問題にしているエラーに関わる部分は、
専ら＜処理４＞で、他の処理は無関係であることをまず確認してください。
＞With .Characters(pos, Len(rng.Value)).Font 　'ここでエラー！！
＞.Bold = True '検索語句を太字
＞.ColorIndex = IIf(rng.Column >= Range("CN1").Column, 5, 3) '着色（赤と青）
＞End With
この４行をコメントブロック（先頭に ' を付加）すれば、エラーが再現されないこと。
逆に
＞.Interior.ColorIndex = 36 '対象セルを薄黄色に
＞rng.Interior.ColorIndex = 36 '検索語句セルを薄黄色に
・・・
＞Cells(.Row, rng.Column).Value = Cells(.Row, rng.Column).Value + 1 '語句カウント
・・・
＞Range("(CH:CH) 2:" & r).Formula = "=SUM(AG2:CG2)"
＞Range("(CM:CM) 2:" & r).Formula = "=SUM(CN2:DF2)"
＞Range("(CJ:CJ) 2:" & r).Formula = "=AND(CH2>0,CM2>0)"
この５行をコメントブロックしても、エラーが再現されること。
以上を踏まえれば＜処理４＞がきっかけとなってエラーを招いていることが見えてきます。
原因を"特定"する為には、段階を追ってひとつひとつ"限定"してゆく作業が
遠いようで近道だったりします。
その為にはやはり、デバッグ（トレース）の方法を身につけることも大切です。

同様のエラー、当方でも再現しました（確認できました）。
＞エクセルのセルが選択できなくなります。
これは、選択はできているけれどもＧＵＩが描画を更新しない、というものかと思います。
＞エクセル自体が終了できなくなり
これも、Alt+F4では終了できるようですから、同じ現象かと。

＞「実行時エラー’-2147417848 (80010108)':
＞'Font' メソッドは失敗しました:　'Characters'　オブジェクト
ご提示のコードで、問題の箇所に構文（文法）上の間違いはありません。
また、Excel（VBA）単体では、他に実現する方法はありません。

＞'Font' メソッドは失敗しました:　'Characters'　オブジェクト
予め想定されていないエラーが発生した場合に適切なエラーコードが用意されていないこと
が偶にありますが、本件もそういうことではないかと思っています。

＃まあ私が今ここで書くのは確度の低い予想のようなものとして読んでおいて欲しいのですが。

恐らく、比較的大量のメモリを食う処理で、処理に使われたメモリが開放されないうちに、
また次の処理、次の処理、と続けるうちにメモリ不足が起きている、とか、
その手のエラーであろうかと思います。
　XL2000とXL2003、バージョン（SP）（による処理方法）の違い
　OSのバージョン（SP）（による処理方法）の違い
　マシンスペック（RAM）の違い
どれもありそうですが、
XL2003でも（大量のデータを渡したところ）同様のエラーが再現できましたから、
（XL2003なら安心ということでもないようです）
何れにしても量的な問題ということは当てはまると思います。
が、直接的な対処策を見つけることは出来ませんでした。

類推するに、Excelにおける.Charactors.Fontの処理は連続して大量に実行することを
想定して作られたものではない、というようなことなのではないでしょうか。
例えば、
.Charactorsと「-s」で終わるオブジェクト名を持ちながら
コレクションを有していない珍しいオブジェクトであること、や、
.ClearFormatsを実行してもリセットされないこと、など、
その特殊性から思うに、
Excelとしてはそもそも「チョイおまけ」的な機能だったりするのかも知れません。

＃調べても文献にあたることができなかった私です。
＃その分、他の方も回答付けにくいだろうなぁ、というか私にとっても大冒険だったり、、、
私個人のExcelの経験的なものとして
　254桁を超えるテキストをセル値に設定するブックを扱ったことがないこと。
　.Charactors.Fontを扱ったことが殆どないこと。
　関連した処理を研究したことがないこと。
まあ今回それなりに勉強はしたのですが割り引いて読んでおいてください（しつこい？）。

で、＜処理４＞のようなものを実現するのに相応しい方法は？というと、
アプリケーションとしてはテキストエディタ、とか、
HTMLなどのマークアップ言語体系、とか、
になるのかな？と思います。（←ここら辺も私はど素人）
　・Ms Word の書式置換（+全置換、正規表現）を使った例。
　・Microsoft Web Brouser コントロール （ソースにタグ挿入）を使った例、
２例、後述します。

ところで、検索対象セルの1000文字を超えるテキストって、セル内改行を含むのでしょうか？
＃＃セル内改行に対応する方法は見つけることが出来ないでいます。
1000文字を超えるテキストを改行なしでユーザーに読ませるとしたら、
検索語をマークアップしたものを全行に渡って一覧できる親切さと、不釣合いな印象を受けます。
そもそも1000文字を超えるテキストを100行以上手入力ってことはないでしょうから、
データ取り込みの方法によっては全く違う視点で解決策があるような気もします。
特に指定がないので、ここでは、セル内改行はないものとして書いています。

少し本題から離れますが、
ご提示のプロシージャのうち＜処理４＞以外の処理について、
「一度で済む同一の処理」（.Interior.Colorとか）を複数回繰り返している点は気になります。
いっそ、
　＜処理２＞検索語句出現数カウント、２群毎の小計及びＡＮＤフラグ（数式出力）
に、「検索語句毎の出現数カウント合計出力」を盛り込んで（不要なら後で消去）、
合計が０以上ならば
　＜処理３＞検索語句リスト、Ｈｉｔ→背景着色
というように、着色する回数を１度だけにする工夫をしてみてはどうでしょう。
（ご提示のものは、ここでいう合計の数だけ繰り返し着色していることになっています。）
その他の処理においても、フラグを採るのに元となる値が共通していることから、
ひとつのプロシージャで、ひとつのループで、まとめて処理することの合理性をみている
のでしょうけれど、
時には一旦セルに書き出した方が他の処理を容易にしてくれる場合もあります。
＜処理５＞検索対象セル、検索語句Ｈｉｔ→背景着色
については、ご提示の（消し忘れ？）
flg = Not (flg)........（正しくはflg = False........でしょうか）
が、処理を一度で済ますよう管理しているフラグであろうと思いますが、
他の４つとは性質（次元）の違うフラグですから、
分けて書いた場合の編集しやすさ、についても一度考えてもらえれば、と思います。
或いは、中間処理をコンパクトにまとめて、且つ、中間処理をセルに出力することは避け、
というスタイルを貫くなら、配列変数を使うことを避けられないだろうと思います。
実際の記述とは違うものを提示なさっているのでしょうけれど、
こちらから見えるものにだけレスを残しておきます。

余談ですが、
＞qa/7054631
期待以上の理解と実践に、ちょっと嬉しい気持ちでありました。Thanks

次の回答で
２つの例を挙げておきます。
いずれも可能な限り簡略化して書いています（細かな問題は色々残ります）。

（次の回答につづく）

この回答へのお礼

cj_moverさん、お礼が大変遅くなり申し訳ございません。
いろいろありましてこのサイトを見ておりませんでした。
ごめんなさい。
そして、わたしの状態を再現していただいたようで感謝感激です。
アドバイスもいちいちその通りです。
本当に有難うございました。

お礼日時：2011/12/14 17:35

No.2 回答者： ki-aaa 回答日時： 2011/10/13 08:12

私の予想です。

このプログラムはセルの書式を設定するものですね。

2000や2003では、書式の数の制限が4000位だったと思います。

書式の数を減らすには、新しいブックに作り直すしかないような気がします。

エクセル　書式の数が多すぎる・・・のキーワードで検索してみてください。

この回答へのお礼

ありがとうございます。

> 書式の数が多すぎる・・・

テストデータですが、500行です。
これが2列ですから、すべてのセルに書式を設定したとしても1000セルです。
あと、Range("AG1:CG1,CN1:DF1") の検索語句リストですから、これも最大72セル
他のセルは「標準」のままですから、書式が設定されたセルは最大1072ということになります。

それに今回のテストは同一データでやってますので、エラーが出るときと出ないときがあるのが書式の数のせいとすると腑に落ちないのです。
あと、エラーが出た後は必ずセルの選択ができなくなり、ファイルは終了できるのにエクセル自体は砂時計のまま固まって終了できなくなることも？？？？です。

お礼日時：2011/10/13 10:11

No.1 回答者： nicotinism 回答日時： 2011/10/12 22:39

期待して見たなら、ごめんなさい。

見辛かったので、インデントを全角スペースにしただけです。
（こちらのサイトは半角スペースやタブは無視されますが全角スペースは生きてます）

Sub Try111012()
　　Dim tgtC As Range, myWrd As Range, rng As Range, myC As Range
　　Dim r As Long, pos As Long
　　Dim t As Single

　　t = Timer
　　r = Cells(Rows.Count, "A").End(xlUp).Row '最終行取得
　　Set tgtC = Range("(R:R,Y:Y) 2:" & r) '検索対象範囲

　　With tgtC
　　　　.Font.ColorIndex = xlAutomatic
　　　　.Font.FontStyle = "標準"
　　　　.Interior.ColorIndex = xlNone
　　End With
　　
　　Range("(AG:DF) 2:" & r).ClearContents 'カウントクリア

　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual

　　Set myWrd = Range("AG1:CG1,CN1:DF1") '検索語句リスト

　　For Each myC In tgtC '各検索対象セル
　　　　flg = Not (flg)
　　　　Application.StatusBar = myC.Address(0, 0) & " を検索中" 　　'検索セル表示
　　
　　　　With myC
　　　　　　For Each rng In myWrd '各検索語句
　　　　　　　　pos = InStr(1, .Value, rng.Value) '発見位置
　
　　　　　　　　If pos > 0 Then 'ヒットしたら
　　　　　　　　　　.Interior.ColorIndex = 36 '対象セルを薄黄色に
　　　　　　　　　　rng.Interior.ColorIndex = 36 '検索語句セルを薄黄色に
　　　　　　　　End If
　　　　　　　　
　　　　　　　　Do While pos > 0 '同じ語句が発見されてるかぎり
　　　　　　　　　　With .Characters(pos, Len(rng.Value)).Font 　　'ここでエラー！！
　　　　　　　　　　　　.Bold = True '検索語句を太字
　　　　　　　　　　　　.ColorIndex = IIf(rng.Column >= Range("CN1").Column, 5, 3) '着色（赤と青）
　　　　　　　　　　End With
　　　　　　　　　　Cells(.Row, rng.Column).Value = Cells(.Row, rng.Column).Value + 1 '語句カウント
　　　　　　　　　　pos = InStr(pos + 1, .Value, rng.Value) 'セル内検索位置移動
　　　　　　　　Loop '繰り返し
　　　　　　　　
　　　　　　Next rng '次の検索語句へ
　　　　End With
　　　　
　　Next myC '次の検索対象セルへ

　　Range("(CH:CH) 2:" & r).Formula = "=SUM(AG2:CG2)"
　　Range("(CM:CM) 2:" & r).Formula = "=SUM(CN2:DF2)"
　　Range("(CJ:CJ) 2:" & r).Formula = "=AND(CH2>0,CM2>0)"

　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Debug.Print Timer - t

　　MsgBox "キーワードを検索して着色しました。" & _
　　vbNewLine & "出現数も調べました。"
　　Application.StatusBar = ""
End Sub

この回答へのお礼

ありがとうございます。
VBエディターではちゃんとインデントしてるのに、このサイトに貼るとみんな消えてしまうんですよね。
インデントを全角スペースに置き換えてくださったのですね。
ありがとうございます。

お礼日時：2011/10/13 10:13