- ベストアンサー
調子よく使用していたコードが、急にエラーに!
Wendy02の回答
こんにちは。 これで、終わりにはするつもりでは書いていますが、私が見ている限りは、なんとかサポートは続けていくつもりです。 元のコード自体は、別の人が書けば別ですが、そんなに変えようがないと思います。もともと、AutoFilterの範囲を取るところに関しては、触れていません。その部分に、焦点を与えることを考えてみました。元のコードにエラー処理を入れる方法もありますが、なんとなく、ちぐはぐになってきてしまうような気がしました。 (a) >1、 256列全てにオートフィルタ(▼)がかかる。 の場合と、 If .AutoFilter.Range.Columns.Count = .Columns.Count Then (b)エラーが起きたときに、オブジェクトを再取得するための、エラー処理対策に飛ぶように、 On Error GoTo ErrHandler ---> ErrHandler: -------> Resume というスタイルにしてやることを考えました。 しかし、(b)の対策を取るのは、私は今のところ状況が見えていません。 余談になりますが、実際に、私の使っているオートフィルタには、そうした問題が起こらないのは、範囲は半固定式ですが、AutoFilter を設けるにしても、範囲は、Range("A1").CurrentRegion というような暗黙的な範囲を取りません。 たぶん、そのイベント・ドリブン型のマクロコード自体の問題ではなくて、その範囲の取り方の問題だと考えました。 ただし、範囲を取るマクロは、ある程度の人間の判断が必要です。 そこで、(a) だけの対策で、AutoFilter の再取得するところから考えてみました。 誤取得をしないような方策をいろいろ立てたコードですが、果たして、うまく取れるかは分かりません。 '------------------------------------------- 'オートフィルタの範囲を取るマクロ Sub SetAutoFilter() 'マウスカーソルを、データのあるところに置いてください。 Dim x As Long Dim y As Long Dim rng As Range 'オートフィルタ解除 If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False 'Exit Sub ''オートフィルタのOn/Off のトグルにする場合 End If If ActiveCell.Value = "" Then MsgBox "ActiveCell にデータがありません。", 48 Exit Sub End If Set rng = ActiveCell.CurrentRegion With rng If Application.CountA(.Cells) < 3 Then MsgBox "オートフィルタ用のデータとして不足しています。", vbInformation Exit Sub End If End With With rng.Cells(1, 1) If rng.Columns.Count > 1 Then x = .End(xlToRight).Column Else '1列しかない場合 x = .Column End If y = .End(xlDown).Row If x = Rows.Count Then x = Application.CountA(rng.Rows(1)) If x < 3 Then MsgBox "オートフィルタ用の行数が足りません。", 48: Exit Sub End If End With With ActiveSheet 'オートフィルタを作る .Range(rng.Cells(1), .Cells(y, x)).AutoFilter End With End Sub
関連するQ&A
- エクセル 最終行からの連続コピー
エクセルで最終行から上に連続する10行(最終行含む)をコピーしたいです。 途中、空白行が含まれている場合でも、最終行を特定し、コピーできるようにするには、下記のコードにどう手を加えたらよいでしょうか? どなたかアドバイスをお願いします。 Sub Test() Dim i As Long Dim j As Integer Dim rng As Range With ActiveSheet 'フィルタ .Range("A1").CurrentRegion.AutoFilter Field:=1 '行選択 With .AutoFilter.Range For i = .Cells(.Cells.Count).Row To 2 Step -1 If .Rows(i).Hidden = False Then If rng Is Nothing Then Set rng = .Rows(i) Else Set rng = Union(rng, .Rows(i)) End If j = j + 1 End If If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Worksheets("Sheet2").Range("A1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With End With Set rng = Nothing なお、コードはこちらを参考にさせていただきました。 http://okwave.jp/qa3552420.html?ans_count_asc=1
- 締切済み
- その他MS Office製品
- コードへ追記したら、特定のシートしか実行できません!
Windows XP Home Edition Excel 2002 http://oshiete1.goo.ne.jp/qa4952620.html 以前に、ご教授頂いたコードに少し追記して、しばらく問題なく使用していましたが、 本日、同ブックの他のシートで実行しましたら、無反応で、セルに色が付きません(エラーではありません)。 何度も行ってみましたが同じ結果です。 但し、'★部分「Offset(-1, 0)」の2箇所を削除して実行するとセルに色が付き、問題なく実行できます。 ちなみに、実行できないシートは、1行全部にオートフィルタ(▼)がかかってしまいます。 私は、いつもEntireRowにてオートフィルタ(▼)をかけております。 しかし、10列ぐらいだけにオートフィルタ(▼)をかけて、実行しても結果は、無反応で、セルに色が付きません。 問題なく実行できるシートでは、EntireRowにてオートフィルタ(▼)をかけても、データのある列までしか オートフィルタ(▼)がかかりません。 このコードは、どんなシートでも実行できると思っていたのですが、 特定のシートでしか実行できないのでしょうか? 原因がわかりません。 よろしくお願い致します。 ------------ 'SheetModule Option Explicit Sub Worksheet_Calculate() Static r As Range Dim f As Filter Dim i As Long On Error GoTo errHndler With ActiveSheet If .AutoFilterMode Then With .AutoFilter If r Is Nothing Then Set r = .Range.Rows(1) For Each f In .Filters i = i + 1 '★ r.Cells(i).Offset(-1, 0).Interior.ColorIndex = IIf(f.On, 33, xlNone) '33()が、識別用 ColorIndex。任意で。 Next f End With Else '★ If Not r Is Nothing Then r.Offset(-1, 0).Interior.ColorIndex = xlNone Set r = Nothing End If End With errHndler: If Err.Number <> 0 Then MsgBox Err.Number & ":" & Err.Description End Sub
- ベストアンサー
- オフィス系ソフト
- 複数セル参照で塗りつぶしを変更する
WIN:XP Off:2003 お願いします。 添付した図は入出金表です。 列Hに数値が入力されると列Eのセルが青く塗りつぶされます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim aCell As Range Set Rng = Intersect(Target, Range("H:H")) If Rng Is Nothing Then Exit Sub For Each aCell In Rng If aCell.Value > 0 Then aCell.Offset(0, -3).Interior.ColorIndex = 17 Else aCell.Offset(0, -3).Interior.ColorIndex = xlNone End If Next aCell Set Rng = Nothing End Sub ここまでは出来たのですが、列Iに入力された時に列Eが赤に塗りつぶされるにはどうしたらいいでしょうか? 同じ行のHとIに同時に数値が入る事はありません。 どうかお願い致します。
- ベストアンサー
- Visual Basic
- エクセル 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は下記とおりです。約35行ほどでエラーです。 Private Sub Worksheet_Change(ByVal Target As Range) Set myRng = Range("B2") '2行目の設定 For Each c In myRng If c.Value = "" Then c.Interior.ColorIndex = 2 'B2が空白ならばセルの色を白色 ElseIf c.Value = Range("I2") Then c.Interior.ColorIndex = 3 'B2=I2ならばセルの色を赤色 ElseIf c.Value = Range("J2") Then c.Interior.ColorIndex = 6 'B2=J2ならばセルの色を黄色 ElseIf c.Value = Range("K2") Then c.Interior.ColorIndex = 6 'B2=K2ならばセルの色を黄色 ElseIf c.Value = Range("L2") Then c.Interior.ColorIndex = 8 'B2=L2ならばセルの色を青色 ElseIf c.Value = Range("M2") Then c.Interior.ColorIndex = 8 'B2=M2ならばセルの色を青色 Else c.Interior.ColorIndex = xINone End If Next c Set myRng = Range("C2") '2行目の設定 For Each c In myRng If c.Value = "" Then c.Interior.ColorIndex = 2 'C2が空白ならばセルの色を白色 ElseIf c.Value = Range("I2") Then c.Interior.ColorIndex = 6 'C2=I2ならばセルの色を黄色 ElseIf c.Value = Range("J2") Then c.Interior.ColorIndex = 6 'C2=J2ならばセルの色を黄色 ElseIf c.Value = Range("K2") Then c.Interior.ColorIndex = 6 'C2=K2ならばセルの色を黄色 ElseIf c.Value = Range("L2") Then c.Interior.ColorIndex = 8 'C2=L2ならばセルの色を青色 ElseIf c.Value = Range("M2") Then c.Interior.ColorIndex = 8 'C2=M2ならばセルの色を青色 Else c.Interior.ColorIndex = xINone End If Next c Set myRng = Range("D2") '2行目の設定 For Each c In myRng If c.Value = "" Then c.Interior.ColorIndex = 2 'D2が空白ならばセルの色を白色 ElseIf c.Value = Range("I2") Then c.Interior.ColorIndex = 6 'D2=I2ならばセルの色を黄色 ElseIf c.Value = Range("J2") Then c.Interior.ColorIndex = 6 'D2=J2ならばセルの色を黄色 ElseIf c.Value = Range("K2") Then c.Interior.ColorIndex = 6 'D2=K2ならばセルの色を黄色 ElseIf c.Value = Range("L2") Then c.Interior.ColorIndex = 8 'D2=L2ならばセルの色を青色 ElseIf c.Value = Range("M2") Then c.Interior.ColorIndex = 8 'D2=M2ならばセルの色を青色 Else c.Interior.ColorIndex = xINone End If Next c ・ ・ End Sub
- ベストアンサー
- オフィス系ソフト
- 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
- 条件付き書式での色付けで以下のコードを教えて頂いたんですが、色付けを
条件付き書式での色付けで以下のコードを教えて頂いたんですが、色付けを 適用する範囲をどうやって変更すればいいのでしょうか? もしよろしければ、範囲の変更の仕方と、コードの意味を教えて頂けますか? めんどうですがよろしくお願いします・・・。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Columns(3).Interior.ColorIndex = xlNone Dim i, j As Long For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row For j = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Cells(i, 3) = Cells(j, 6) Then Cells(i, 3).Interior.ColorIndex = Cells(j, 7).Interior.ColorIndex End If Next j Next i End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル 最終行からの連続コピー
* すぐに回答を! エクセルC20からI51までデータを1日1行ずつ入力します。 データが入力されている最終行から上に連続する10行(最終行含む)をコピーしたいのですが、最終行から10行上をどのように認識させたらいいのか、わかりません。Offsetなど試してみましたがダメでした。 よろしくお願いします。 Sub dataコピー() Dim i As Long Dim j As Integer Dim rng As Range '最後尾から10行前までを選択 With Worksheets("月").Range(Cells(20, 3), Cells(51, 10)) For i = Cells(Rows.Count, 1).End(xlUp).Row To -10? If rng Is Nothing Then Set rng = .Rows(i) End If j = j + 1 If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Range("M1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With Set rng = Nothing End Sub コードはこちらを参考にしました http://questionbox.jp.msn.com/qa5440189.html
- 締切済み
- オフィス系ソフト
- マクロの簡素化
下記マクロです。 Range("AE6:AE1005").Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone If Range("AD6").Value > 5 Then Range("AE6") = "*" Range("AE6").Select With Selection.Interior .ColorIndex = 3 End With Else End If If Range("AD7").Value > 5 Then Range("AE7") = "*" Range("AE7").Select With Selection.Interior .ColorIndex = 3 End With Else End If If Range("AD8").Value > 5 Then Range("AE8") = "*" Range("AE8").Select With Selection.Interior .ColorIndex = 3 End With Else End If 中略(セルを一個づつ指定しています) If Range("AD1004").Value > 5 Then Range("AE1004") = "*" Range("AE1004").Select With Selection.Interior .ColorIndex = 3 End With End If If Range("AD1005").Value > 5 Then Range("AE1005") = "*" Range("AE1005").Select With Selection.Interior .ColorIndex = 3 End With Else End If Range("AE3").Select 有るセルを参照しその値が5以上だったら別のセルに*マークとセルに色を付けるマクロですが、一個づつセル指定をしていますが、何とか短く出来ないでしょうか? お分かりになる方宜しくお願い致します。
- ベストアンサー
- その他(プログラミング・開発)
- このVBAソースのどこが間違ってるか教えてください
Dim csp As Integer 'ストップ Dim css As Integer 'ストップorスタート Sub Quest2() If css = 0 Then css = 1 Quest2a Else cstp = 1 css = 0 End If End Sub Sub Quest2a() Sheets("Sheet1").Select Range("B1:J10").Select Selection.Interior.ColorIndex = x1None Range("a1").Select cstp = 0 Do r = 1: c = 5 For i = 0 To 15 If i < 9 Then Cells(r, c).Interior.ColorIndex = x1None r = r + 1 If i < 5 Then c = c + 1 Else c = c - 1 End If Cells(r, c).Interior.ColorIndex = 3 Else Cells(r, c).Interior.ColorIndex = x1None r = r - 1 If i < 13 Then c = c - 1 Else c = c + 1 End If Cells().Interior.ColorIndex = 3 End If 'タイミング For tm1 = 1 To 1000: For tm2 = 1 To 100: Next If cstp = 1 Then Exit For End If Next DoEvents If cstp = 1 Then Exit For End If If r = 3 And c = 5 Then Cells(r, c).Interior.ColorIndex = x1None End If Next DoEvents If cstp = 1 Then Exit Do End If Loop Cells(10, 9) = Cells(r, c) Cells(10, 9).Interior.ColorIndex = 8 End Sub
- ベストアンサー
- その他(プログラミング・開発)
お礼
こんばんは。 度々のご回答、大変に恐れ入ります。 大変、有りがたく存じております。 >たぶん、そのイベント・ドリブン型のマクロコード自体の問題ではなくて、その範囲の取り方の問題だと考えました。 >ただし、範囲を取るマクロは、ある程度の人間の判断が必要です。 非常に遅ればせながらですが、なんとか解かってきました。 自分としては、なんとなく解かっていたつもりなんですが、 どおしても、(自身で荒っぽく使用したりしてるようなので) 自分のブック自体の原因かもとも思っていて、はっきりしませんでしたので、 あえてご質問をさせて頂いた次第でございます。 また、最近では、データがだいぶ蓄積してきまして、操作が重くなってきたりしたりで、 (ブック自体に何か支障が出てきたりしたのではと) いろいろと少し気になっておりました。 今も、いろいろと範囲の取り方を試しておりましたが、少しずつですが解かってきました。 誠に有難うございました。