入力したデータのエラーチェックをしたいです。

Question

Sheet1のA列に個人番号、B列に氏名が入っています。C列からG列までに1から50までの整数が入っている表があります。1行目がタイトル行で、2行目以下にデータが入っています。

ただ条件があって、例えば、ある人のC列からG列までのどこかに1が入っている場合は、13, 27, 41がその他の列に入っている場合、エラーとしてわかる(該当セルに色を塗る)ようにしたいのですが、どうしたらいいでしょうか？

実際は上記のような条件がいくつもあるのでVBAを用いてするしかないと思うのですが、やり方が思いつきません。If ～ thenでひとつひとつチェックする以外に効率的な方法があれば教えてください。

Excel2007を使っています。

mt2008 · Accepted Answer

「そのほか」がどれだけあるのか解らないので、別シートにそのリストを作る前提でサンプルマクロ作ってみました。
＃かなり強引なマクロですが……

「ErChk」と言うシートにエラーの条件を入力しておくものとします。
「ErChk」シートの書式は添付画像を参照してください。
Sheet1に入力後、以下のマクロを起動するとエラー箇所を塗りつぶします。

Sub Sample()
　　Worksheets("Sheet1").Select
　　Columns("C:G").Interior.Pattern = xlNone
　　nMax = Cells(Rows.Count, 2).End(xlUp).Row
　　For i = 2 To nMax '氏名が入っている最後の行まで
　　　　'定義シート「ErChk」にエラーチェックの定義が入っていること
　　　　For j = 2 To Worksheets("ErChk").Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　If WorksheetFunction.CountIf(Range(Cells(i, 3), Cells(i, 7)), Worksheets("ErChk").Cells(j, 1)) > 0 Then
　　　　　　　　For k = 2 To 4  'エラーをチェックするのはErChk B:D列の3種類の値
　　　　　　　　　　nChk = Worksheets("ErChk").Cells(j, k)
　　　　　　　　　　For l = 3 To 7  'Sheet1のC～G列が塗りつぶし対象
　　　　　　　　　　　　If Cells(i, l) = nChk Then
　　　　　　　　　　　　　　Cells(i, l).Interior.ThemeColor = xlThemeColorAccent6
　　　　　　　　　　　　End If
　　　　　　　　　　Next l
　　　　　　　　Next k
　　　　　　End If
　　　　Next j
　　Next i
End Sub

tsubuyuki · Answer

えーと・・・４番でお邪魔した者です＾＾；

皆さまの回答を拝見していて・・質問文を読み返して・・・
ようやく気付いたんですが・・・
これは「入力されているデータに対して」行う処理なのですね＾＾；；
私、勘違いして「新しく入力されたデータに対して」の処理を考えてました＾＾；；

なので、「入力されているデータに対する処理」バージョンを、今さらですが。

Sub test2()
Dim TRange As Object, TCell As Object
Dim myErr As Variant
Dim TRow As Long, i As Integer, j As Integer

Application.ScreenUpdating = False
　　
　　Columns("C:G").Interior.Pattern = xlNone　　　
　　
　　For TRow = 2 To Range("B" & Rows.Count).End(xlUp).Row　　
　　　　Set TRange = Range("C" & TRow & ":G" & TRow)　　　
　　　　For i = 2 To Range("J" & Rows.Count).End(xlUp).Row
　　　　　　Set myErr = Range("J" & i & ":M" & i)
　　　　　　Set TCell = TRange.Find(What:=myErr(1), LookAt:=xlWhole)
　　　　　　If Not TCell Is Nothing Then
　　　　　　　　For j = 2 To 4
　　　　　　　　　　For Each myCell In TRange
　　　　　　　　　　　　If myCell = myErr(j) Then
　　　　　　　　　　　　　　myCell.Interior.Color = RGB(0, 255, 255)
　　　　　　　　　　　　End If　
　　　　　　　　　　Next　
　　　　　　　　Next j　
　　　　　　End If　
　　　　　　Set myErr = Nothing:Set TCell = Nothing　
　　　　Next i　
　　Next TRow

Set TRange = Nothing: Set TCell = Nothing: Set myErr = Nothing　
　　Application.ScreenUpdating = True
　　
　　Msgbox "処理完了"　
End Sub

データ件数（行数）が１０００行（一郎～千郎まで）、対象が５列（正味５０００セル）、
条件を７種類用意し、１／３～半分（２０００～２５００セル）を塗り潰す感じのテストデータを
添付図のように「条件を列記した表」と比較して、色を付けていきます。
（テストの都合上、数値の範囲を１～２０までとしてランダムに打っていますので
　数字に重複が有ったりしますが、見逃してくださいませ。）

配列の考え方が入るので若干ややこしいですが、読み解くと意外と簡単です。

ちなみに（私のパソコンで）０．８～１秒で処理が終わります。

JazzCorp · Answer

性能対策版（ハイライト処理簡略）
１万行全部にトリガをセットしても10秒かかりません。

Option Explicit
Sub HighLightCells()
Const xName = "Sheet1"      'シート名
Const xHeads = 1        'ヘッダ行数
Const xColumn = 3 'チェックする範囲From
Const xColumn2 = 7 'チェックする範囲To
Const xKeyValue = 1 'マークする条件値
'Const xDoBonValue = "13,47,99" 'マークする値
Const xBlack = 1
Const xWhite = 2
Const xBlue = 5
Const xYellow = 6
Dim kk As Long
Dim nn As Long
Dim mm As Long
Dim xSheet As Worksheet
Dim xLast As Long
Dim xDoBon() As Variant
Dim xMatch As Boolean
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'xDoBon = Split(xDoBonValue, ",")
'xDoBon = Array(14, 27, 41, 1, 55, 77, 99)
xDoBon = Array(14, 27, 41)      'マークする値
Set xSheet = Sheets(xName)
xSheet.Range(xSheet.Columns(xColumn), xSheet.Columns(xColumn2)).Interior.Pattern = xlNone
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
For nn = 1 + xHeads To xLast
xMatch = (WorksheetFunction.CountIf(xSheet.Range(xSheet.Cells(nn, xColumn), xSheet.Cells(nn, xColumn2)), xKeyValue) > 0)
If (xMatch) Then
For kk = xColumn To xColumn2
For mm = 0 To UBound(xDoBon)
If (xSheet.Cells(nn, kk) = xDoBon(mm)) Then
'HighLight
xSheet.Cells(nn, kk).Interior.ColorIndex = xYellow
Exit For
End If
Next mm
Next kk
End If
Next nn
Application.CutCopyMode = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

JazzCorp · Answer

マークしたい値を変更するときは、
Const xDoBonValue = "13,47,99" 'マークする値
ではなく、コードの中に隠れているこちらを適当に変えてみてオクレヤス、、、
xDoBon = Array(14, 27, 41)
１万魚で１分もかかりマスタ、反省、、、

tom04 · Answer

No.7です。

お礼欄の二つの件について・・・

前回のコードに応用を効かせる行を載せておきます。

（1）条件が現在７つぐらいあり、まだこの先増える可能性もありますし
は
＞myArray = Array(13, 27, 41)
の中に追加していきます。
仮に　13・27.41.48・49　がエラーと判断する場合は
＞myArray = Array(13, 27, 41, 48, 49)
のようにカンマで区切って追加してください。
今回は数値ですので、ダブルクォーテーションは必要ありませんが、
文字列の場合は
＞myArray = Array("あ", "い", "う")
のようにします。

（2）問題は、最初にエラーになる決まりが決まっているのではなく、後から決まったり
は
＞Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,1),1,"""")"
の行で調整します。

上記はCOUNTIF関数そのものですので、
D列～H列に「1」があればA列に「1」を表示、なければ「空白」に！というコトです。
（A列を挿入していますので、元データが右へ1列ずつずれ、上記数式となります）
仮にエラーになる値「4」が範囲内にあれば
＞Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,4),1,"""")"
に変更します。

あとはA列が「1」でオートフィルタをかけ、Sheet2にコピーする方法は変更なしで大丈夫です。

上記二点の訂正で、おそらく条件が変わっても対応できると思います。
（マクロ実行前に、塗りつぶしをすべて「なし」にしておく必要があります）

こんなんでお役に立ちますかね？m(_ _)m

tom04 · Answer

こんばんは！

データ量が多い場合、For～Nextで関係のない行もLoopさせても
無駄に時間を要するだけですので、
オートフィルタで「1」がある行だけを別Sheetに抽出し、そのデータ内でloopさせる方法はどうでしょうか？

その一例です。
作業用のSheetとしてSheet2を使用していますので、Sheet2はまったく使用していない！という前提です。

Sub test()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim mG As Long
    Dim nG As Long
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet
    Dim myArray As Variant
    
    Set wS1 = Worksheets("Sheet1")
    Set wS2 = Worksheets("Sheet2")
    
    myArray = Array(13, 27, 41)
    i = wS1.Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    wS1.Columns(1).Insert
    Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,1),1,"""")"
    wS1.Cells(1, 1).CurrentRegion.AutoFilter field:=1, Criteria1:="1"
    Range(wS1.Columns(1), wS1.Columns(8)).Copy wS2.Cells(1, 1)
    
    For j = 4 To 8
    For nG = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
    For k = 0 To UBound(myArray)
        If wS2.Cells(nG, j) = myArray(k) Then
            mG = WorksheetFunction.Match(wS2.Cells(nG, 2), Columns(2), False)
            wS1.Cells(mG, j).Interior.ColorIndex = 6    '←黄色にしています。
        End If
    Next k
    Next nG
    Next j
    
    wS1.Columns(1).Delete
    wS2.Cells.Clear
    wS1.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

JazzCorp · Answer

Option Explicit
Sub HighLightCells()
Const xName = "Sheet1"
Const xHeads = 1
Const xKeyValue = 1                       'マークする条件値
Const xDoBonValue = "13,47,99"      'マークする値
Const xColumn = 3                          'チェックする範囲From
Const xColumn2 = 7                        'チェックする範囲To
Const xBlack = 1
Const xWhite = 2
Const xBlue = 5
Const xYellow = 6
Dim xSheet As Worksheet
Dim xLast As Long
Dim xDoBon() As Variant
Dim xMatch As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'xDoBon = Split(xDoBonValue, ",")
xDoBon = Array(13, 47, 99)
Set xSheet = Sheets(xName)
xLast = xSheet.UsedRange.Rows.Count
For nn = 1 + xHeads To xLast
For kk = xColumn To xColumn2
'Reset
xSheet.Cells(nn, kk).Font.Bold = False
xSheet.Cells(nn, kk).Font.ColorIndex = xBlack
xSheet.Cells(nn, kk).Interior.ColorIndex = xWhite
Next kk
Next nn

xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
For nn = 1 + xHeads To xLast
xMatch = False
For kk = xColumn To xColumn2
If (xSheet.Cells(nn, kk) = xKeyValue) Then
xMatch = True
Exit For
End If
Next kk
If (xMatch) Then
For kk = xColumn To xColumn2
For mm = 0 To UBound(xDoBon)
If (xSheet.Cells(nn, kk) = xDoBon(mm)) Then
'HighLight
xSheet.Cells(nn, kk).Font.Bold = True
xSheet.Cells(nn, kk).Font.ColorIndex = xYellow
xSheet.Cells(nn, kk).Interior.ColorIndex = xBlue
Exit For
End If
Next mm
Next kk
End If
Next nn
Application.CutCopyMode = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

tsubuyuki · Answer

急ごしらえで書き方は雑ですが。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Object, myCell As Range
Dim myRow As Long, i As Long

myRow = Target.Row
　　
　　For i = 1 To 50
　　　　With Range(Cells(myRow, 3), Cells(myRow, 7))
　　　　　　.FormatConditions.Delete
　　　　　　Set myRange = .Find(What:="1", LookAt:=xlWhole)
　　　　　　　　If Not myRange Is Nothing Then
　　　　　　　　　　For Each myCell In Range(Cells(myRow, 3), Cells(myRow, 7))
　　　　　　　　　　　　If myCell = 14 Or myCell = 27 Or myCell = 41 Then
　　　　　　　　　　　　　　myCell.Interior.Color = RGB(255, 0, 0)
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　myCell.Interior.ColorIndex = xlNone
　　　　　　　　　　　　End If
　　　　　　　　　　Next
　　　　　　　　Else
　　　　　　　　　　For Each myCell In Range(Cells(myRow, 3), Cells(myRow, 7))
　　　　　　　　　　　　myCell.Interior.ColorIndex = xlNone
　　　　　　　　　　Next
　　　　　　　　End If
　　　　End With
　　Next
End Sub

こんな感じでセル５個に対して「条件判断→書式設定」を
> 1から50までの整数
との事なので、５０回繰り返し、正味で２５０回の書式設定を繰り返しましたが、
（こんな雑な書き方でも）０．１秒かからずに終了しました。

これを効率的と見るか、非効率的と見るかの判断はお任せします。

これに例えば
> ある人のC列からG列までのどこかに1が入っている場合は、13, 27, 41がその他の列に入っている場合、エラー
> ある人のC列からG列まで2が入力されている場合は、その他のセルには7,19,47はエラー
この「１・２」が同時に発生するケースはどうするのか？などの条件が入ると
コードももう少し捻る必要がありそうですが、
それがないのであれば上記のコードの繰り返しの中で条件設定していけば
気になるほどの時間はかからないはずですよ。

とりあえず、
> If ～ thenでひとつひとつチェックする以外に効率的な方法があれば
ご自身で検証した「非効率と判断したIf～Thenを使ったコード」があればご提示くださいませ。

mt2008 · Answer

ANo.2です。

> 前の方の回答にも書きましたが、同じような条件が他にもあるのですが、その場合はどうしたらいいのでしょうか？

他にもとは、どの程度あるのでしょう。
3～4つなら条件付き書式でやってしまうのが手っ取り早いですし、それ以上ならVBAでしょう。

mt2008 · Answer

以下の様な条件付き書式で実現できますよ。
=AND(COUNTIF($C2:$G2,1)>0,OR(C2=13,C2=27,C2=41))

入力したデータのエラーチェックをしたいです。

「そのほか」がどれだけあるのか解らないので、別シートにそのリストを作る前提でサンプルマクロ作ってみました。

えーと・・・４番でお邪魔した者です＾＾；

性能対策版（ハイライト処理簡略）

マークしたい値を変更するときは、

No.7です。

こんばんは！

Option Explicit

急ごしらえで書き方は雑ですが。

ANo.2です。

以下の様な条件付き書式で実現できますよ。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング