| |
よろしくお願いします。
>ichinoseさん
>Lindyさん
>Jakaさん
>皆さん ありがとうございます。
>コードの内容はあまりわかりませんが
>どれも完璧です。
>コードをよーく見て少しずつ勉強します。
>
>★★追加で申し訳ないのですが条件がさらに増えるのですが
> A B C D E F
>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 火 午前
> ： ： ： ： ： ：
>
D列までの重複した人間を対象にE、Fの重複のチェック(色を変えて表示)を
したいのですが、難しいでしょうか？
>よろしくお願いします。
ichinoseさんのコードに加味したのですが
修正方法がいまいちわかりません。
ご教授いただけないでしょうか
よろしくお願いします。
'========================================================
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
|
|
ｓｓｃ
- 07/8/24(金) 17:50 -
