| |
>標準モジュールに
>
>'========================================================
>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 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(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
。
|
|
ichinose
- 07/8/23(木) 9:33 -
