| |
▼ichinose さん：
ありがとうございます。
実行結果のですが
実行時エラー13
型が一致しませんが
出ます。
デバッグしましたが原因解りません
よろしくお願いします。
>>No.・氏名・プロジェクトの項目列は２行目から
>>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
>
>'打合せ日と時間をチェックリストとして登録できるように変更しました。
>
>テストしてみてください。
|
|
ssc
- 07/8/25(土) 16:23 -
