行ごとに判定するマクロについての要約
- 行ごとに判定するマクロについて教えて下さい。
- 行ごとに判定するマクロを組みたいのですが、現在のマクロでは行ごとではなく、指定のセル範囲全体で同じ数値がないかを判断しています。
- 何か他の方法で行ごとに判定するように修正する方法はありますか?
- ベストアンサー
行ごとに判定するマクロについて教えて下さい
行ごとに判定するマクロについて教えて下さい。 下記のようなマクロで、添付ファイルのように、行ごとで E列からN列で違った数値がないか、入力されていないセルがないかを調べ 4つすべてのセルが同じ数値でない場合は塗りつぶしはされず O列にOKを表示しないようなマクロを組みたいのですが 現在のマクロだと、行ごとではなく、E3~N102セルまでの中で 同じ数値がないかを判断してしまっているため K11セルやK15セルのように数値が入力されていないにも関わらずO列の部分にOKが出てしまいます。 他の行に同じ数値が入っているのは関係なしにして 11行目なら11行目だけで 15行目なら15行目だけで、というように行ごに判定していくには どのようにすればいいでしょうか? Sub 判定マクロ回転() Dim i As Integer, j As Integer Range(Cells(3, 15), Cells(102, 15)).ClearContents For i = 3 To 102 For j = 5 To 14 Cells(i, j).Interior.ColorIndex = 0 If WorksheetFunction.CountIf(Range("E3:N102"), Cells(i, j)) > 3 Then If Cells(i, j).Row Mod 2 = 1 Then Cells(i, j).Interior.ColorIndex = 6 Cells(i, 15) = "OK" Else If Cells(i, j).Row Mod 2 = 0 Then Cells(i, j).Interior.ColorIndex = 40 Cells(i, 15) = "OK" End If End If End If Next j Next i If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub
- yyrd0421
- お礼率50% (86/170)
- Excel(エクセル)
- 回答数4
- ありがとう数1
- みんなの回答 (4)
- 専門家の回答
質問者が選んだベストアンサー
偶数行と奇数行で色分けを忘れてました。たびたび訂正ですみません。 Sub example() Dim i As Integer Range(Cells(3, "O"), Cells(102, "O")).ClearContents Range(Cells(3, "E"), Cells(102, "N")).Interior.ColorIndex = 0 For i = 3 To 102 If WorksheetFunction.CountIf(Range(Cells(i, "E"), Cells(i, "N")), Cells(i, "E")) > 3 Then With Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K"), Cells(i, "N")) If i Mod 2 = 1 Then .Interior.ColorIndex = 6 Else .Interior.ColorIndex = 40 End If End With Cells(i, "O") = "OK" End If Next If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub
その他の回答 (3)
- kkkkkm
- ベストアンサー率65% (1618/2457)
訂正 Range(Cells(3, "O"), Cells(102, "O")).Interior.ColorIndex = 0 ↓ Range(Cells(3, "E"), Cells(102, "N")).Interior.ColorIndex = 0 でした。
- kkkkkm
- ベストアンサー率65% (1618/2457)
行全部を対象にするとまずい場合(E列からN列までを対象にする場合) If WorksheetFunction.CountIf(Rows(i), Cells(i, "E")) > 3 Then ↓ If WorksheetFunction.CountIf(Range(Cells(i, "E"), Cells(i, "N")), Cells(i, "E")) > 3 Then に変更してください。
- kkkkkm
- ベストアンサー率65% (1618/2457)
下記でいかがでしょう。 Sub example() Dim i As Integer, j As Integer Range(Cells(3, "O"), Cells(102, "O")).ClearContents Range(Cells(3, "O"), Cells(102, "O")).Interior.ColorIndex = 0 For i = 3 To 102 If WorksheetFunction.CountIf(Rows(i), Cells(i, "E")) > 3 Then Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K"), Cells(i, "N")).Interior.ColorIndex = 6 Cells(i, "O") = "OK" End If Next If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub
関連するQ&A
- 公差を設定して判定するマクロ
規格を設けて判定するマクロについて教えてください。 下記のようなマクロがあるとき、現在はE列、H列、K列が同じ数値の場合は 塗りつぶしが行われるようになっています。 これを少し改造して、B4セルに公差の数値を入力した時 E列の数値を基準とし、H列、K列がE列からB4セルに入力した公差内なら色を付けるような マクロを組みたいです。 例えばB4セルに2と入力してあるとします。 E列の数値が4.2だとした場合 H列は2.2、K列は6.2ならE列の数値の±2なので塗りつぶしされる。 E列の数値にB4セルの入力した数値の±をH列、K列を超える場合は 塗りつぶしは行わない、という感じです。 わかりずらい説明で申し訳ありませんが、宜しくお願いします。 Sub 判定仮() Dim i As Integer, j As Integer Range(Cells(3, "L"), Cells(32, "L")).ClearContents Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0 For i = 3 To 32 If WorksheetFunction.CountIf(Rows(i), Cells(i, "E")) > 2 Then If Cells(i, "E").Row Mod 2 = 1 Then Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 6 Cells(i, "L") = "OK" Else If Cells(i, "E").Row Mod 2 = 0 Then Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 40 Cells(i, "L") = "OK" End If End If End If Next If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then MsgBox "データチェックOK(^O^)b" End If End Sub
- ベストアンサー
- Excel(エクセル)
- 公差を設定して判定するマクロの続き
質問No.9150010の続きです。 上記の質問で下記のようなご回答を頂きました。 E列の数値に対してB4セルに入力されている公差の数値に H列とK列の数値が入っているか調べるマクロです。 下記のマクロで完璧に行えるようになりましたが もしE列の数値に対して、公差内に入っていない数値がH列とK列にあった場合 その公差内に入っていないセルのみを赤く塗りつぶすには下記のマクロにどうのように追加すればよいでしょうか? パターンとしてはH列もしくはK列のどちらかのみが公差内に入っていない時もあれば 両方とも公差内に入っていない場合もあります。 Sub 判定仮本物() Dim i As Integer, j As Integer Dim k As Double Range(Cells(3, "L"), Cells(32, "L")).ClearContents Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0 k = Cells(4, 2) 'B4セルの値 For i = 3 To 32 If Abs(Cells(i, "E") - Cells(i, "H")) <= k And Abs(Cells(i, "E") - Cells(i, "K")) <= k Then If i Mod 2 = 1 Then Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 6 Cells(i, "L") = "OK" Else Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 40 Cells(i, "L") = "OK" End If End If Next If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then MsgBox "データチェックOK(^O^)b" End If End Sub
- ベストアンサー
- Excel(エクセル)
- 判定してセルを塗りつぶすマクロについて
判定してセルを塗りつぶすマクロについて教えて下さい。 現在下記のようなマクロがあります。 Sub オニオン判定() Dim i As Integer, j As Integer, r As Integer Dim k As Double Range(Cells(17, 9), Cells(26, 14)).Interior.ColorIndex = 0 Range(Cells(30, 9), Cells(39, 14)).Interior.ColorIndex = 0 k = Cells(5, 2) 'B5セルの値 For j = 9 To 14 For i = 17 To 26 For r = 30 To 39 If Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then Cells(r, j).Interior.Color = vbYellow Cells(i, j).Interior.Color = vbYellow End If Next Next Next End Sub 対象のIf Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then で、それぞれ見比べて、0.05以上のずれがあるとセルが塗りつぶされないというマクロなのですが これを、If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenという条件も追加して その時はセルを青に塗りつぶし、逆に0.05以上のずれがあるセルは赤に塗りつぶす。 みたいなマクロを書きたいです。 If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenは一度追加してみましたが 上手く機能しませんでした。 やりたい事 ・数値が動いているけど、0.05以内の時は黄色 ・数値変動が0の場合は青 ・数値変動が0.05以上の場合は赤 です。 宜しくお願いします。
- ベストアンサー
- Excel(エクセル)
- マクロ 色が思うように、表示できない
下記のようなコードで部品の管理をしています。条件が多くて少し複雑になっています。 とりあえずは、うまくできました。J列の結果だけが、うまくできません。 但し、J列の結果が(38はローズ )の表示がうまくいきません。(6の黄色)になってしまいます。 要するに、J列の結果が不がローズ色で、合が白色で、欠が薄いオレンジ色になればよいということなのです。 原因が分からず困ってしまって、お聞きする次第です。回答して頂けるものでしようか。 ご教授下されば幸いに存じます。よろしくお願いします。 Macro2 Macro マクロ記録日 : ' Sheets("sheet1").Select Columns("A:J").Select Selection.Copy Sheets("sheet2").Select Columns("A:J").Select ActiveSheet.Paste Application.CutCopyMode = False Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin, DataOption1:=xlSortNormal Dim i As Long, LastRow As Long LastRow = Cells(Rows.Count, "A").End(xlUp).Row Range("J2:J" & LastRow).ClearContents '← E2:Jにすると、欠に全部なります、この設定もおかしいように思いますが? Range("E2:J" & LastRow).Interior.ColorIndex = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '文言の詳細について '部品名と詳細-------------------------------------略称 'ghyu--------------------------------------←E列 'klub---------------------------------------←F列 'llpo----------------------------------------←G列 '合計個数(合計)-------------------------←H列 合計 '数量順位---------------------------------←I列 順位 '合格・不合格(合・不)欠品(欠)-----←J列 合・不・欠 If Cells(i, "E") >= 1 And Cells(i, "E") < 20 Then Cells(i, "E").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "F") >= 1 And Cells(i, "F") < 6 Then Cells(i, "F").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "F") >= 6 And Cells(i, "F") < 10 Then Cells(i, "F").Interior.ColorIndex = 34 '34は 淡い青色 End If If Cells(i, "G") >= 1 And Cells(i, "G") < 10 Then Cells(i, "G").Interior.ColorIndex = 6 ' 6は 黄色 End If If Cells(i, "H") >= 1 And Cells(i, "H") <= 49 Then Cells(i, "H").Interior.ColorIndex = 4 ' 4は うぐいす色 End If If Cells(i, "J") >= "不" Then Cells(i, "J").Interior.ColorIndex = 38 '38は ローズ End If If Cells(i, "J") >= "合" Then Cells(i, "J").Interior.ColorIndex = 2 ' 2は 白色 End If For j = 5 To 9 'D-F If Cells(i, j).Value = 0 Then Cells(i, j).Interior.ColorIndex = 3 '3は 赤色 ElseIf Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色 End If Next j For k = 5 To 9 'G-I If Cells(i, j).Value = "欠" Then Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色 End If Next k Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- エクセル マクロ 複数セルの色付けについて
マクロ初心者で苦戦しており、教えていただけると大変ありがたいです。 エクセルの複数のシートに、問2_1 、問2_2 、問2_10 (全部で問は2_28まであります)等の文字列があり、その文字に合わせて、そのセルだけ色を付けたいと考えております。 今書いているコードだと、ワークシートのA列にある場合は色が付けられるのですが、それ以外に色が付けられません。どこが間違っているでしょうか? どうぞご指導お願いいたします。 Sub 色つけ() Dim Maxrow As Long Dim i As Long Maxrow = Cells(Rows.Count, i).End(xlUp).Row For i = 1 To Maxrow If InStr(Cells(i, 1), "2_1 ") > 0 Then Cells(i, 1).Interior.ColorIndex = 6 If InStr(Cells(i, 1), "2_2 ") > 0 Then Cells(i, 1).Interior.ColorIndex = 6 If InStr(Cells(i, 1), "2_23 ") > 0 Then Cells(i, 1).Interior.ColorIndex = 23 If InStr(Cells(i, 1), "2_13 ") > 0 Then Cells(i, 1).Interior.ColorIndex = 4 If InStr(Cells(i, 1), "2_6 ") > 0 Then Cells(i, 1).Interior.ColorIndex = 7 Next i End Sub
- 締切済み
- Visual Basic
- マクロ 検索範囲を修正したい 1つ置きのセルで
前に以下のマクロをここで教えていただきました。このときはB列からF列の範囲でお願いしたのですが、F列~AG列の1つ置きのセル(G、I、K・・・列)で検索したいです。どう修正したらよいですか?初心者なので調べても分からなかったので教えてください。 Sub Sample1() 'この行から Dim i As Long, j As Long, vL vL = InputBox("検索値を入力してください。") Application.ScreenUpdating = False Cells.Interior.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To 5 With Cells(i, j) If .Value <> "" And .Value >= vL - 3 And .Value <= vL + 3 Then .Interior.ColorIndex = 36 End If End With Next j Next i Application.ScreenUpdating = True End Sub 'この行まで
- ベストアンサー
- オフィス系ソフト
- エクセルマクロ 【空白セルを無視する方法を教えてください】
マクロを独学で学び仕事に応用しているのですが、どうしても分からないことが発生してしまい、質問です。 内容は、今、エクセルシートのA1~B5の範囲で A B 1 1 1 2 1 2 3 4 1 5 1 という形で入力されています(見難くてスミマセン)。 この状態から「A列とB列に同じ数字が入力されてれば、メッセージBOXを表示して、なおかつOKボタンを押したら該当セルを赤くする」というマクロを作りたいのですが、本来であれば1行目のみ赤くなるはずなのですが、空白セルが含まれている3行目も赤くなってしまうんです。つまり、空白セルも「同じ値」と認識されているみたいなのですが...。 この場合、空白セルを無視するにはどうしたらよいのですか?教えてください。なお、マクロは以下のように作っています。 Sub ナンバーチェック() Dim Btn As Integer For X = 5 To 10 If Cells(X, "A").Value = Cells(X, "B").Value Then Btn = MsgBox("同じ数値です", vbOK, "警告") If Btn = vbOK Then Cells(X, "A").Interior.ColorIndex = 3 Cells(X, "B").Interior.ColorIndex = 3 End If End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- For Nextマクロの高速化についてご教示ください。
エクセル2000です。 以下は、ワークシートのA列の2行目以降に赤(Interior.ColorIndex = 3 )のセルがあればその行を非表示に、1行目のA列以降に赤いセルがあればその列を非表示にする単純なマクロです。通常はストレスなく動いてくれるのですが、あるBOOKにこのマクロを設定したら、わずか200行程度の処理に1分以上かかってしまいました。 そのBOOKは1.4MBあるのでそのせいとも思えるのですが、それにしても時間がかかりすぎるような気もします。 高速化する方法がありましたらご教示くださいませ。 (o。_。)oペコッ Private Sub 行列非表示() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False With ActiveSheet x = .Cells(1, 1).SpecialCells(xlLastCell).Row y = .Cells(1, 1).SpecialCells(xlLastCell).Column For i = 2 To x If .Cells(i, "A").Interior.ColorIndex = 3 Then .Rows(i).Hidden = True End If Application.StatusBar = i Next i For n = 1 To y If .Cells(1, n).Interior.ColorIndex = 3 Then .Columns(n).Hidden = True End If Application.StatusBar = n Next n End With Application.StatusBar = "" Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Exit Sub End Sub
- ベストアンサー
- オフィス系ソフト
- 選択した行のみマクロを使いたい
以前、こちらのサイトで表を展開するマクロを教えていただきました。 そのマクロをシート全体ではなく、任意の行や任意のセルにだけに使えるようにしたいです。 Sub 展開() Dim nLast As Long Dim vAdata, i, j Dim vData nLast = Cells(Rows.Count, 1).End(xlUp).Row '行を追加削除する時は下から上が基本 For i = nLast To 1 Step -1 vAdata = Cells(i, 1) 'A列が空白ではなく、B列が空白の場合、B列以降を上と同じにする If (vAdata <> "") And (Cells(i, 2) = "") And (i > 1) Then Rows(i) = Rows(Cells(i, 2).End(xlUp).Row).Value Cells(i, 1) = vAdata End If If vAdata = "" Then 'A列の値が空白なら削除 Rows(i).Delete Shift:=xlUp Else 'A列の最後に「,」が有る場合は取り除く If Right(vAdata, 1) = "," Then vAdata = Left(vAdata, Len(vAdata) - 1) End If vData = Split(vAdata, ",") 'A列の値がカンマで区切られていた場合 If UBound(vData) > 0 Then '対象行をコピーして区切られていた数-1だけ下に挿入 Rows(i).Copy Rows(i & ":" & i + UBound(vData) - 1).Insert Shift:=xlDown 'A列の値を区切られていた値に書き換える For j = 0 To UBound(vData) Cells(i + j, 1) = vData(j) Next j End If End If Next i End Sub というマクロを教えて頂きました。 これをどのようにすればいいでしょうか? ご教授お願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルマクロ セルの色つけ
エクセルのマクロです。 条件で複数セルに色をつけたいのですが以下の方法しかないですか。 もっと多くのセルに一度に色を付ける良い方法がありましたら教えて下さい。 If days = "日" Then With Cells(i, 2).Interior .ColorIndex = 3 .Pattern = xlSolid End With With Cells(i, 13).Interior .ColorIndex = 3 .Pattern = xlSolid End With End If 以上 お願いします。
- ベストアンサー
- Visual Basic
お礼
ご回答ありがとうございました。 希望通りのマクロになり大変勉強になりました。 何度も訂正、追加もして頂きありがとうございます。 今後ともよろしくお願いします。