| |
▼ssc さん：
こんにちは。
>No.・氏名・プロジェクトの項目列は２行目から
>
>1.期間重複のチェック
>このこの段階で 4佐藤太郎 6鈴木一男 7佐藤太郎が期間重複に
>該当します。(薄い緑色)
>
>2.打合せ日重複のチェック
>期間重複該当の佐藤太郎・鈴木一男を対象に打合せ日の重複をチェック
>下表の場合鈴木一男が該当F4:G4とF8:G8が重複していますので色付(黄色)
>※佐藤太郎の場合打合せ日の曜日は重複していますが午前・午後でG4・G9
>異なりますのでチェックにはかかりません。
>こんな仕上がりを希望しています。
>
>A B C D E F G
>No. 氏 名 プロジェクト 開始日 終了日 打合せ日 時間
>1 佐藤太郎 あああ 2007/4/1 2007/10/31 水 午後
>2 鈴木一男 いいい 2007/3/1 2007/12/31 火 午後
>3 山田次郎 ううう 2007/2/1 2007/8/31 木 午後
>4 佐藤太郎 えええ 2007/10/1 2008/3/31 月 午前
>5 田村三郎 おおお 2007/4/1 2007/11/30 水 午後
>6 鈴木一男 かかか 2007/5/1 2008/5/31 火 午後
>7 佐藤太郎 ききき 2007/8/20 2008/3/31 水 午前
>8 山田次郎 くくく 2007/11/20 2008/5/31 火 午後
上記のデータが入力データとして、
標準モジュールに
'============================================================
Option Explicit
'============================================================
Sub main()
Dim rng As Range
Dim g0 As Long
Dim g1 As Long
Dim c_array As Variant
Dim st1 As Long, ed1 As Long
Dim ret As Boolean
Cells.Interior.ColorIndex = xlNone
Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp))
If rng.Row > 1 Then
init_ovl_chk_tbl
For g0 = 1 To rng.Count
c_array = get_ovl_chk_tbl(rng(g0, 2).Value)
If TypeName(c_array) = "Boolean" Then
Call add_ovl_chk_tbl(rng(g0, 2).Value, CLng(rng(g0, 4).Value), _
CLng(rng(g0, 5).Value), rng(g0, 6).Value, _
rng(g0, 7).Value)
Else
st1 = CLng(rng(g0, 4).Value)
ed1 = CLng(rng(g0, 5).Value)
ret = True
For g1 = LBound(c_array) To UBound(c_array) Step 4
If chk_ovl(st1, ed1, c_array(g1), c_array(g1 + 1)) Then
rng(g0).Resize(, 7).Interior.ColorIndex = 35
If rng(g0, 6).Value = c_array(g1 + 2) And _
rng(g0, 7).Value = c_array(g1 + 3) Then
rng(g0).Resize(, 7).Interior.ColorIndex = 6
End If
ret = False
Exit For
End If
Next g1
If ret = True Then
Call add_ovl_chk_tbl(rng(g0, 2).Value, st1, ed1, _
rng(g0, 6).Value, rng(g0, 7).Value)
End If
End If
Next g0
term_ovl_chk_tbl
End If
End Sub
'mainは多少ですが変更があります。
'============================================================
Function chk_ovl(ByVal st1 As Long, ByVal ed1 As Long, ByVal st2 As Long, ByVal ed2 As Long) As Boolean
'機能 ： st1からed1の範囲とst2からed2の範囲で重なりの有無をチェックする
'input : st1 ed1 st2 ed2 開始値及び、終了値
'output: chk_ovl true 重なりあり False 重なりなし
' 例
' st1 10 ed1 20 st2 5 ed2 16の場合、chk_ovl True
' st1 10 ed1 20 st2 11 ed2 16の場合、chk_ovl True
' st1 10 ed1 20 st2 16 ed2 30の場合、chk_ovl True
' st1 10 ed1 20 st2 5 ed2 9の場合、chk_ovl false
' st1 10 ed1 20 st2 22 ed2 32の場合、chk_ovl false
Dim myarray As Variant
myarray = Application.Frequency(Array(st1, ed1), Array(st2, ed2))
If myarray(1, 1) < 2 And myarray(3, 1) < 2 Then
chk_ovl = True
Else
chk_ovl = st1 = ed1 And ed1 = st2 And st2 = ed2
' 前回の投稿にバグがありました↑これに変えてください
End If
Erase myarray
End Function
別の標準モジュールに
'=================================================================
Option Explicit
'=================================================================
Private dic As Object
Sub init_ovl_chk_tbl()
'重なりチェックリストテーブルの初期化
Set dic = CreateObject("scripting.dictionary")
End Sub
'=================================================================
Sub term_ovl_chk_tbl()
'重なりチェックリストテーブルの終了処理
Set dic = Nothing
End Sub
'=================================================================
Sub add_ovl_chk_tbl(ByVal c_key As Variant, ByVal st As Long, _
ByVal ed As Long, ByVal chkdate As Variant, _
ByVal chktime As Variant)
'重なりチェックリストテーブルへのチェックデータの追加
Dim ans As Variant
If dic.Exists(c_key) Then
ans = dic(c_key)
ReDim Preserve ans(1 To UBound(ans) + 4)
ans(UBound(ans) - 3) = st
ans(UBound(ans) - 2) = ed
ans(UBound(ans) - 1) = chkdate
ans(UBound(ans)) = chktime
dic(c_key) = ans
Else
ReDim ans(1 To 4)
ans(1) = st
ans(2) = ed
ans(3) = chkdate
ans(4) = chktime
dic.Add c_key, ans
End If
End Sub
'=================================================================
Function get_ovl_chk_tbl(c_key As Variant) As Variant
'重なりチェックリストテーブルへからチェックデータの取得
If dic.Exists(c_key) Then
get_ovl_chk_tbl = dic(c_key)
Else
get_ovl_chk_tbl = False
End If
End Function
'打合せ日と時間をチェックリストとして登録できるように変更しました。
テストしてみてください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
