| |
こんばんは。
これは、ちょっと難しいですねえ！！
>毎日、Ｃ列の日付とともにＤ列に3桁の数値を入力します。
>その数値とは165 〜975の数値で、すべて存在する訳ではなく、抜けている数値もあります。（たとえば、167、193などは抜けています）
>Ｄ列の入力方法はＣ列のように昇順ではなく、ランダム的な入力方法です。
>
>しかし、下記のような入力方法のルールがあります。
>＊「同じ日付（Ｃ列）に対応する同じ数値（Ｄ列）は、続けて入力しなければいけ ない」
> 下記の例だと、Ｄ10の177が入力ミスです。
>
>[追加コード]
>下記のＤ10の177のように、このルールに反してＤ列に入力した場合、「入力ミス」と表示したいのです。
> Ａ Ｂ Ｃ Ｄ列
> １ 1 2007/1/31 176
> ２ 2 2007/1/31 187
> ３ 3 2007/1/31 177
> ４ 4 2007/2/1 176
> ５ 5 2007/2/2 188
> ６ 6 2007/2/3 177
> ７ 7 2007/2/3 177
> ８ 8 2007/2/3 975
> ９ 9 2007/2/3 170
>１０ 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
これでＤ列の数値入力してみてください
数字が連続していなければ、エラーメッセージが表示されます。
細かいコメントや説明をしませんから、じっくり解読してみてください。
結構大変ですよ！！
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
