エクセルVBAの実行時エラー
- エクセル2000でマクロを実行すると、'Font' メソッドは失敗しましたエラーが発生します。
- エラーが発生すると、エクセルのセルが選択できなくなります。
- ファイルの終了はできますが、エクセル自体が終了できなくなります。
- ベストアンサー
エクセルVBAの実行時エラー
先日からこちらでいろいろ教えていただき、以下を行うマクロを書きました。 R列とY列の2行目以下(行数は不定、ただしA列の行数に一致します。)の各セルにかなり長文の文字列があります。 短いので50文字程度、長いのは1000文字を超えます。 この各セルを、Range("AG1:CG1,CN1:DF1") の検索語句リストに記載の文字列で検索をかけます。 同一セル内に同じ検索文字列が複数ある場合もありますし、どの検索文字列も存在しないセルもあります。 ヒットしたら、該当の検索対象セルと該当の検索語句がある検索語句リストのセルを薄黄色に着色します。 その際、該当の検索対象セルと同一行、かつ該当の検索語句がある検索語句リストのセルと同一列のセルに+1をして出現数をカウントします。 ヒットしたら、該当の検索対象セル内の検索語句を着色し、太字にします。 着色は検索語句リストの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
- emaxemax
- お礼率100% (823/823)
- その他MS Office製品
- 回答数5
- ありがとう数5
- みんなの回答 (5)
- 専門家の回答
質問者が選んだベストアンサー
回答No.3の続きです。 前述の<処理4>の部分だけをWordの書式置換を使って実現するものです。 .PasteSpecial Paste:="HTML" この一行(2回実行)が際立って時間をとります。 Office2000 Xp 1.2GHz 256MB 合致:70(うち一文字の検索語句4)/ 72語 500行 545188文字、書式置換: 33252件 ↑を基準に書きました。 (同一環境でこの3倍くらいのデータ量で100回位は再起動なしで通りました) (大量データ向きです。) ' ' ====標準モジュール 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 コントロール (ソースにタグ挿入)を使った例です。 <処理4>は行わず(ファイルを軽く保って) ユーザー操作(右クリック)で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
その他の回答 (4)
- cj_mover
- ベストアンサー率76% (292/381)
#あまりにも酷かったので 訂正です。 誤>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のまま、一度に大量の処理をしない工夫を施すのも ありかも知れないですね。
お礼
なんどもありがとうございます。 高度すぎて私には豚に真珠ですがほんとうに有難うございました。
- cj_mover
- ベストアンサー率76% (292/381)
こんにちは。 だいぶ日が経っていますが一応回答らしきものをあげてみます。 http://okwave.jp/qa/q7054631.html http://okwave.jp/qa/q7058428.html このふたつが関連した質問ということでよいでしょうか。 まず処理の内容を整理してみると、 <処理1>検索語句出現数カウント、数値出力 <処理2>検索語句出現数カウント、2群毎の小計及びANDフラグ(数式出力) <処理3>検索語句リスト、Hit→背景着色 <処理4>検索対象セル、検索語句Match→.Charactors.Font.Color <処理5>検索対象セル、検索語句Hit→背景着色 大別して5つですね。 このうち、質問で問題にしているエラーに関わる部分は、 専ら<処理4>で、他の処理は無関係であることをまず確認してください。 >With .Characters(pos, Len(rng.Value)).Font 'ここでエラー!! >.Bold = True '検索語句を太字 >.ColorIndex = IIf(rng.Column >= Range("CN1").Column, 5, 3) '着色(赤と青) >End With この4行をコメントブロック(先頭に ' を付加)すれば、エラーが再現されないこと。 逆に >.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)" この5行をコメントブロックしても、エラーが再現されること。 以上を踏まえれば<処理4>がきっかけとなってエラーを招いていることが見えてきます。 原因を"特定"する為には、段階を追ってひとつひとつ"限定"してゆく作業が 遠いようで近道だったりします。 その為にはやはり、デバッグ(トレース)の方法を身につけることも大切です。 同様のエラー、当方でも再現しました(確認できました)。 >エクセルのセルが選択できなくなります。 これは、選択はできているけれどもGUIが描画を更新しない、というものかと思います。 >エクセル自体が終了できなくなり これも、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を扱ったことが殆どないこと。 関連した処理を研究したことがないこと。 まあ今回それなりに勉強はしたのですが割り引いて読んでおいてください(しつこい?)。 で、<処理4>のようなものを実現するのに相応しい方法は?というと、 アプリケーションとしてはテキストエディタ、とか、 HTMLなどのマークアップ言語体系、とか、 になるのかな?と思います。(←ここら辺も私はど素人) ・Ms Word の書式置換(+全置換、正規表現)を使った例。 ・Microsoft Web Brouser コントロール (ソースにタグ挿入)を使った例、 2例、後述します。 ところで、検索対象セルの1000文字を超えるテキストって、セル内改行を含むのでしょうか? ##セル内改行に対応する方法は見つけることが出来ないでいます。 1000文字を超えるテキストを改行なしでユーザーに読ませるとしたら、 検索語をマークアップしたものを全行に渡って一覧できる親切さと、不釣合いな印象を受けます。 そもそも1000文字を超えるテキストを100行以上手入力ってことはないでしょうから、 データ取り込みの方法によっては全く違う視点で解決策があるような気もします。 特に指定がないので、ここでは、セル内改行はないものとして書いています。 少し本題から離れますが、 ご提示のプロシージャのうち<処理4>以外の処理について、 「一度で済む同一の処理」(.Interior.Colorとか)を複数回繰り返している点は気になります。 いっそ、 <処理2>検索語句出現数カウント、2群毎の小計及びANDフラグ(数式出力) に、「検索語句毎の出現数カウント合計出力」を盛り込んで(不要なら後で消去)、 合計が0以上ならば <処理3>検索語句リスト、Hit→背景着色 というように、着色する回数を1度だけにする工夫をしてみてはどうでしょう。 (ご提示のものは、ここでいう合計の数だけ繰り返し着色していることになっています。) その他の処理においても、フラグを採るのに元となる値が共通していることから、 ひとつのプロシージャで、ひとつのループで、まとめて処理することの合理性をみている のでしょうけれど、 時には一旦セルに書き出した方が他の処理を容易にしてくれる場合もあります。 <処理5>検索対象セル、検索語句Hit→背景着色 については、ご提示の(消し忘れ?) flg = Not (flg)........(正しくはflg = False........でしょうか) が、処理を一度で済ますよう管理しているフラグであろうと思いますが、 他の4つとは性質(次元)の違うフラグですから、 分けて書いた場合の編集しやすさ、についても一度考えてもらえれば、と思います。 或いは、中間処理をコンパクトにまとめて、且つ、中間処理をセルに出力することは避け、 というスタイルを貫くなら、配列変数を使うことを避けられないだろうと思います。 実際の記述とは違うものを提示なさっているのでしょうけれど、 こちらから見えるものにだけレスを残しておきます。 余談ですが、 >qa/7054631 期待以上の理解と実践に、ちょっと嬉しい気持ちでありました。Thanks 次の回答で 2つの例を挙げておきます。 いずれも可能な限り簡略化して書いています(細かな問題は色々残ります)。 (次の回答につづく)
お礼
cj_moverさん、お礼が大変遅くなり申し訳ございません。 いろいろありましてこのサイトを見ておりませんでした。 ごめんなさい。 そして、わたしの状態を再現していただいたようで感謝感激です。 アドバイスもいちいちその通りです。 本当に有難うございました。
- ki-aaa
- ベストアンサー率49% (105/213)
私の予想です。 このプログラムはセルの書式を設定するものですね。 2000や2003では、書式の数の制限が4000位だったと思います。 書式の数を減らすには、新しいブックに作り直すしかないような気がします。 エクセル 書式の数が多すぎる・・・のキーワードで検索してみてください。
お礼
ありがとうございます。 > 書式の数が多すぎる・・・ テストデータですが、500行です。 これが2列ですから、すべてのセルに書式を設定したとしても1000セルです。 あと、Range("AG1:CG1,CN1:DF1") の検索語句リストですから、これも最大72セル 他のセルは「標準」のままですから、書式が設定されたセルは最大1072ということになります。 それに今回のテストは同一データでやってますので、エラーが出るときと出ないときがあるのが書式の数のせいとすると腑に落ちないのです。 あと、エラーが出た後は必ずセルの選択ができなくなり、ファイルは終了できるのにエクセル自体は砂時計のまま固まって終了できなくなることも????です。
- nicotinism
- ベストアンサー率70% (1019/1452)
期待して見たなら、ごめんなさい。 見辛かったので、インデントを全角スペースにしただけです。 (こちらのサイトは半角スペースやタブは無視されますが全角スペースは生きてます) 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エディターではちゃんとインデントしてるのに、このサイトに貼るとみんな消えてしまうんですよね。 インデントを全角スペースに置き換えてくださったのですね。 ありがとうございます。
関連するQ&A
- エクセル VBA 検索 スクロール
お世話になります。 A列に製品名、B列に場所と詳細を表した表です。 E1に製品名を入れて検索ボタンを押すと右隣のセルの値がE1に表示され検索件数がMsgBoxに表示されるものをこのページで聞いたりしながら作りました。 'Dim 対象セル As Range 'Dim 最初のセル番地 As String 'Dim 検索件数 As Long Cells.Interior.ColorIndex = xlNone If Range("E1").Value = "" Then Exit Sub Set 対象セル = Range("A2:A1287").Find(What:=Range("E1").Value, After:=Range("A1287"), lookAt:=xlWhole) If 対象セル Is Nothing Then Exit Sub 最初のセル番地 = 対象セル.Address Do 対象セル.Interior.ColorIndex = 37 検索件数 = 検索件数 + 1 Set 対象セル = Range("A2:A1287").FindNext(対象セル) Loop While 対象セル.Address <> 最初のセル番地 Range("E3").Value = 対象セル.Offset(, 1).Value MsgBox "検索件数は" & 検索件数 & " 件です" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) End Sub 今回質問したいのは検索したセルを含む行(製品名によって複数あります)を自動で一番上、A5でウィンドウの固定をしてあるのでA6からの表示になるようにスクロールするにはどのようにしたらいいでしょうか?よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBA 範囲選択時エラー
Private Sub Worksheet_SelectionChangeのVBAでA列B列C列でワンクリックで文字が入力できるように設定致しました。 その後、A列からC列を範囲選択してDeleteするとデバック 「実行時エラー 型が一致しません」と出てしまいます。業務上、そのセルのデータは一気に消したいので困っております。どなたか分かる方よろしくお願い致します。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range, rng_1 As Range, rng_2 As Range Application.EnableEvents = False Set rng_1 = Range("H17:H100") Set rng_2 = Range("I17:I100") Set rng_3 = Range("J17:J100") Set rng_4 = Range("K17:K100") Application.EnableEvents = True Set rng = Intersect(Target, rng_1) If Not rng Is Nothing Then Cancel = True If Target.Value = "" Then Target.Value = "(1)" Else Target.Value = "(1)" End If Else Set rng = Intersect(Target, rng_2) If Not rng Is Nothing Then Cancel = True If Target.Value = "(2)" Then Target.Value = Empty Else Target.Value = "(2)" End If Else Set rng = Intersect(Target, rng_3) If Not rng Is Nothing Then Cancel = True If Target.Value = "(3)" Then Target.Value = Empty Else Target.Value = "(3)" End If Else Set rng = Intersect(Target, rng_4) If Not rng Is Nothing Then Cancel = True If Target.Value = "(4)" Then Target.Value = Empty Else Target.Value = "(4)" End If End If End If End If End If End Sub
- 締切済み
- Visual Basic
- excel vba
VBAに不慣れなので教えてください。 今下記のプログラム(A1セルで青色以外の文字を消去する)はA1セルのみを対象にしているのですが、 (1)セルをA1からA3までにする。 (2)処理対象をA1のある列を対象とするようにしたい。 各々どう手直しすればいいか。 プログラムtest Public Sub test() Dim r As Range Dim i, wk As String Set r = Range("A1") wk = "" For i = 1 To Len(r.Value) Debug.Print r.Characters(i, 1).Font.ColorIndex If r.Characters(i, 1).Font.Color = vbBlue Then wk = wk + r.Characters(i, 1).Text End If Next r.Value = wk r.Characters.Font.Color = vbBlue End Sub
- ベストアンサー
- オフィス系ソフト
- VBA教えてください
VBA初心者です 画像を添付します 赤いセルの背景色に反応し、 C~Eのセルを結合してその中に文字を入れると言うものですが 10/1みたいに全て結合出来れば良いのですが コードを実行した結果 10/5の結果はC~Eのセルは結合されてますが 列の9~11のセルは結合されてないです これをまとめて結合出来るようにしたいです (10/1の結合セルみたいな事をしたいです) コード sub test() const hani as string="A1:E11" dim rng as range for each rng in range(hani) if rng.interior.colorindex= 3 then range(cells(rng.row,3),cells(rng.row,5)).merge cells(rng.row,3).value="停止" end if next rng end sub です。 試行錯誤しましたが変な結果になって手詰まりしてます。 コード書いてもらえるとすごく助かります! 回答お願いします!
- ベストアンサー
- Visual Basic
- シート内セルに条件付着色でエラーメッセージ
Excelのチェックボタンをクリックしたときにシート1のセル"C4:G50"内に条件付書式により着色(ColorIndex =7)されたセルがあった場合、エラーメッセージ(" ヶ所 日付が入力されていません")を表示したいのですが? 下記のコードでセルに直接着色("C7")されたものは添付のようにメッセージが出たのですが条件付書式による着色がカウントしメッセージが出るようにしたいのですが、コード表示が解る方どうかよろしくお願いします。 尚、C列とG列のみ50行まで条件下で着色するよう同じ条件付書式が入っています。 Sub チェック() Dim CheckRange As Range Dim rng As Range Dim cnt As Long Set CheckRange = Range("C4:G50") For Each rng In CheckRange If rng.Interior.ColorIndex = 7 Then cnt = cnt + 1 End If Next If cnt > 0 Then MsgBox cnt & "ヶ所、日付が入力されていません。", vbCritical Exit Sub End If Worksheets("sheet1").Range("D1") = "1" End Sub
- ベストアンサー
- Visual Basic
- エクセルのマクロについて教えてください
お世話になっております。 エクセルのマクロについて教えていただきたいのですが、 サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。 http://kie.nu/yPV 質問したいことは、列Iに、各行の黄色いセルの数を表示させるマクロを作りたいのですが 途中まで何とかわかったのですがどうもうまくいきません。。 行11から各行にひとつずつ、黄色いセルが含まれていますが、その黄色いセルの中の数字を列Iに表示させたいです。行にデータがある限り、下までずっとです。 以下、途中までわかったマクロです。 Sub 黄セル値Copy() Const TgLeftUp = "A3" '<--対象範囲左上セル指定 Dim Rng As Range Dim Target As Range Set Target = Range(TgLeftUp, Cells(Rows.Count, _ Range(TgLeftUp).Column)) For Each Rng In Target.Resize(, 2) If Rng.Interior.ColorIndex = 6 Then If Rng.Column = Target.Column Then Rng.Offset(, 3).Value = Rng.Value Else Rng.Offset(, 2).Value = Rng.Value End If End If Next MsgBox "値 貼り付け完了。", vbInformation Set Target = Nothing End Sub でもこれを貼り付けてもうまくいきません。 正しいマクロを教えていただけないでしょうか?? 宜しくお願いいたします。 ※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。 都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。
- ベストアンサー
- その他MS Office製品
- エクセル VBA セルの色をSheet1とSheet2の両方を変えたいのですが・・・
最近困っているところが表題の通りなのですが Sheet1のB2を右クリックするとB2のセルの色を変えて Sheet2のB2のセルも色を変えたいというものです。 現状で Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim Rng As Range, myRng As Range Dim RngA As Range, myRngA As Range Set Rng = Range("B3:W3,b7:w8,b12:w12,d13:w13,d17:w18,d22:w23") Set myRng = Intersect(Target, Rng) If myRng.Interior.ColorIndex = xlColorIndexNone Then myRng.Interior.ColorIndex = 37 Else If myRng.Interior.ColorIndex = 37 Then myRng.Interior.ColorIndex = 45 Else myRng.Interior.ColorIndex = xlColorIndexNone End If End If Cancel = True End Sub とここまではあるのですが、これをどう改造すればSheet2の同じセルの色もかわるのでしょうか? 宜しくお願いいたします
- ベストアンサー
- オフィス系ソフト
- VBA? 色のついた文字のセルを数えたい
色のついた文字の記載があるセルをカウントしたく 色々調べました。結局VBAで設定する方法にしたのですが 設定しテストをするとどうしてもカウント数が合いません。 全くの初心者の為何が間違っているのか全く分かりません。 どなたか教えて下さい。 VBAも全く知らない者でしたので 調べて以下のものをそのまま貼り付けました。 Function CCount(Rng As Range, idx) Dim R As Range Dim Cnt As Long Application.Volatile For Each R In Rng If R.Font.ColorIndex = idx Then Cnt = Cnt + 1 Next R CCount = Cnt End Function Function GetIndx(Rng As Range) If Rng.Count > 1 Then GetIndx = vbNullString Exit Function End If GetIndx = Rng.Font.ColorIndex End Function 何が間違っているのでしょうか?
- ベストアンサー
- オフィス系ソフト
- エクセル 2010 マクロ 検索
http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim strKey As Variant Dim s As String Dim c As Range, bln As Boolean Dim rng1 As Range Dim cnt As Long Set Ws1 = Sheet1 Set Ws2 = Sheet2 Ws1.Select With Ws2 strKey = Application.Transpose(.Range("A1").Resize(2).Value) strKey = Join(strKey, "") End With If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub With Ws1 Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp)) For Each c In rng1.Offset(, -10) 'D,E,F,G,H,I,Kを検索 s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value & If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then c.End(xlToRight).Activate c.Offset(0, 2).Value = Date c.Resize(1, 14).Interior.ColorIndex = 6 bln = True Exit For End If Next c If Not bln Then Ws2.Select MsgBox "リストに存在しません", vbExclamation, "NotFound" Else '加える Call ReSearch(Ws1.Range("M2"), c.Row) '再設定 Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp)) MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation End If End With Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2) Dim i As Long Dim cnt As Long For i = 1 To rng1.Rows.Count If VarType(rng2.Cells(i, 1)) = vbDouble Then If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then cnt = cnt + 1 End If End If Next i DoubleCountBlank = cnt End Function 宜しくお願い致します。
- ベストアンサー
- Excel(エクセル)
- VBAの記録を追加したい
エクセル2002使用です。 VBAで次のコードを使っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Target = Intersect(Range("C:C"), Target) If Target Is Nothing Then Exit Sub For Each Rng In Target If Rng.Value <> "" Then Rng.Offset(, -2).Value = Now Else ' (*) Rng.Offset(, -2).Value = "" ' (*) End If Next Rng End Sub (C列のセルに何か入力されると、A列の同じ行にその時刻が入る。) 同じシートで、F列に何か入力されるとE列の同じ行にその時刻が入るように書き直したいのですが、どうすればいいのでしょうか? すいませんが、よろしくお願いします。
- ベストアンサー
- Visual Basic
お礼
Sub Re7067351wd()、やってみました。 すごいですね、あまりすごすぎて私の理解がとてもついていけません。 でも正しく作動しました。 有難うございます。