|
こんばんは。
これは、ちょっと難しいですねえ!!
>毎日、C列の日付とともにD列に3桁の数値を入力します。
>その数値とは165 〜975の数値で、すべて存在する訳ではなく、抜けている数値もあります。(たとえば、167、193などは抜けています)
>D列の入力方法はC列のように昇順ではなく、ランダム的な入力方法です。
>
>しかし、下記のような入力方法のルールがあります。
>*「同じ日付(C列)に対応する同じ数値(D列)は、続けて入力しなければいけ ない」
> 下記の例だと、D10の177が入力ミスです。
>
>[追加コード]
>下記のD10の177のように、このルールに反してD列に入力した場合、「入力ミス」と表示したいのです。
> A B C D列
> 1 1 2007/1/31 176
> 2 2 2007/1/31 187
> 3 3 2007/1/31 177
> 4 4 2007/2/1 176
> 5 5 2007/2/2 188
> 6 6 2007/2/3 177
> 7 7 2007/2/3 177
> 8 8 2007/2/3 975
> 9 9 2007/2/3 170
>10 10 2007/2/3 177 ← 入力ミス
数式使うと簡単そうですが 今回も敢えて使いません!!
まず、上記のシートがあるシートモジュールに
(標準モジュールではないですよ!!)
'================================================================
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim crng As Range
Dim drng As Range
Dim rw As Long
Dim dd As Date
Dim retcode As Boolean
Set rng = Application.Intersect(Target, Range("d1:d65536"))
If Not rng Is Nothing Then
For Each crng In rng
If IsDate(crng.Offset(0, -1).Value) Then
retcode = True
dd = crng.Offset(0, -1).Value
rw = 1
Call init_ctn
Do Until Cells(rw, 3).Value = ""
If Cells(rw, 3).Value = dd Then
retcode = chk_ctn(Cells(rw, 4).Value, rw)
If retcode = False Then
Cells(rw, 4).Select
MsgBox "入力ミス"
Exit Do
End If
End If
rw = rw + 1
Loop
Call term_ctn
If retcode = False Then Exit For
End If
Next
End If
End Sub
標準モジュールに
数字の連続性のチェックを行うプロシジャー群
'=========================================================
Option Explicit
Dim ctnvalue() As Variant
Dim ctnrow() As Long
Dim ctnidx As Long
'==========================================================
Sub init_ctn()
'連続性をチェックする内部データの初期化
Erase ctnvalue
Erase ctnrow
ctnidx = 1
End Sub
'==========================================================
Function chk_ctn(ByVal chkvalue As Variant, _
ByVal chkrow As Long) As Boolean
'指定されたデータが連続しているか否かのチェック
'chkvalue 値 chkrow 値の位置
'chk_ctn True 連続している False 連続していない
Dim g0 As Variant
On Error Resume Next
chk_ctn = False
g0 = Application.Match(chkvalue, ctnvalue(), 0)
If IsError(g0) Or Err.Number <> 0 Then
ReDim Preserve ctnvalue(1 To ctnidx)
ReDim Preserve ctnrow(1 To ctnidx)
ctnvalue(ctnidx) = chkvalue
ctnrow(ctnidx) = chkrow
ctnidx = ctnidx + 1
chk_ctn = True
Else
If chkrow = ctnrow(g0) + 1 Then
ctnrow(g0) = chkrow
chk_ctn = True
End If
End If
End Function
'==========================================================
Sub term_ctn()
'連続性チェックの終了処理
On Error Resume Next
Erase ctnvalue()
Erase ctnrow()
ctnidx = 0
End Sub
これでD列の数値入力してみてください
数字が連続していなければ、エラーメッセージが表示されます。
細かいコメントや説明をしませんから、じっくり解読してみてください。
結構大変ですよ!!
|
|