| |
▼ssc さん：
おはようございます。
> A B C D
>1 氏名 プロジェクト 開始日 終了日
>2 佐藤太郎 AAAAA 2007/4/1 2007/10/31
>3 鈴木次郎 BBBBB 2007/3/1 2007/12/31
>4 山田三郎 CCCCC 2007/2/1 2007/9/31
>5 佐藤太郎 DDDDD 2007/10/1 2007/12/31
>6 田中一郎 EEEEE 2007/4/1 2007/11/30
> ： ： ： ：
開始日と終了日が分かれているのでその分だけ処理が楽になりますね！！
データをどのように配置するかは、かなり重要なことですよね？
標準モジュールに
'========================================================
Option Explicit
Sub main()
Dim rng As Range
Dim g0 As Long
Dim g1 As Long
Dim c_carray 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_carray = get_ovl_chk_tbl(rng(g0).Value)
If TypeName(c_carray) = "Boolean" Then
Call add_ovl_chk_tbl(rng(g0).Value, CLng(rng(g0, 3).Value), CLng(rng(g0, 4).Value))
Else
st1 = CLng(rng(g0, 3).Value)
ed1 = CLng(rng(g0, 4).Value)
ret = True
For g1 = LBound(c_carray) To UBound(c_carray) Step 2
If chk_ovl(st1, ed1, c_carray(g1), c_carray(g1 + 1)) Then
rng(g0).Resize(, 4).Interior.ColorIndex = 3
ret = False
Exit For
End If
Next g1
If ret = True Then
Call add_ovl_chk_tbl(rng(g0).Value, st1, ed1)
End If
End If
Next g0
term_ovl_chk_tbl
End If
End Sub
'========================================================================
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 = False
End If
Erase myarray
End Function
別の標準モジュールに
'=================================================================
Option Explicit
Private dic As Dictionary
'=================================================================
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(c_key As Variant, st As Long, ed As Long)
'重なりチェックリストテーブルへのチェックデータの追加
Dim ans As Variant
If dic.Exists(c_key) Then
ans = dic(c_key)
ReDim Preserve ans(1 To UBound(ans) + 2)
ans(UBound(ans) - 1) = st
ans(UBound(ans)) = ed
dic(c_key) = ans
Else
ReDim ans(1 To 2)
ans(1) = st
ans(2) = ed
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
上記のようなデータが配置されているシートをアクティブな状態で
mainを実行してみてください。
期間に重なりのある行が赤く塗りつぶされます。
上記のデータ例だと5行目の佐藤太郎が塗りつぶし対象になります。
尚、データのソートの必要はありません。
試してみてください。
|
|
ichinose
- 07/8/23(木) 7:47 -
