Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


30983 / 76738 ←次へ | 前へ→

【51014】Re:期間が重複していないか確認する方法
発言  ichinose  - 07/8/25(土) 14:45 -

引用なし
パスワード
   ▼ssc さん:
こんにちは。

>No.・氏名・プロジェクトの項目列は2行目から
>
>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

'打合せ日と時間をチェックリストとして登録できるように変更しました。

テストしてみてください。

0 hits

【50935】期間が重複していないか確認する方法 やました 07/8/22(水) 21:00 質問
【50937】Re:期間が重複していないか確認する方法 neptune 07/8/22(水) 21:28 発言
【50943】Re:期間が重複していないか確認する方法 やました 07/8/22(水) 23:36 お礼
【50944】Re:期間が重複していないか確認する方法 ssc 07/8/23(木) 0:23 発言
【50946】Re:期間が重複していないか確認する方法 じゅんじゅん 07/8/23(木) 6:51 発言
【50947】Re:期間が重複していないか確認する方法 ichinose 07/8/23(木) 7:47 発言
【50950】Re:期間が重複していないか確認する方法 訂... ichinose 07/8/23(木) 9:33 発言
【50951】Re:期間が重複していないか確認する方法 じゅんじゅん 07/8/23(木) 9:37 発言
【50953】Re:期間が重複していないか確認する方法 neptune 07/8/23(木) 9:54 回答
【50957】Re:期間が重複していないか確認する方法 じゅんじゅん 07/8/23(木) 10:40 発言
【50955】Re:期間が重複していないか確認する方法 Lindy 07/8/23(木) 10:24 発言
【50962】Re:期間が重複していないか確認する方法 ssc 07/8/23(木) 14:22 質問
【50963】すみませんでした。 Jaka 07/8/23(木) 15:04 発言
【51008】Re:期間が重複していないか確認する方法 ssc 07/8/24(金) 17:50 質問
【51012】Re:期間が重複していないか確認する方法 ichinose 07/8/25(土) 7:31 発言
【51013】Re:期間が重複していないか確認する方法 ssc 07/8/25(土) 12:37 質問
【51014】Re:期間が重複していないか確認する方法 ichinose 07/8/25(土) 14:45 発言
【51016】Re:期間が重複していないか確認する方法 ssc 07/8/25(土) 16:23 発言
【51017】Re:期間が重複していないか確認する方法 ssc 07/8/25(土) 16:38 お礼
【51025】Re:期間が重複していないか確認する方法 ssc 07/8/26(日) 0:10 質問
【51026】Re:期間が重複していないか確認する方法 ichinose 07/8/26(日) 0:19 発言
【51027】Re:期間が重複していないか確認する方法 ssc 07/8/26(日) 0:34 質問
【51028】Re:期間が重複していないか確認する方法 ichinose 07/8/26(日) 0:45 発言
【51030】Re:期間が重複していないか確認する方法 ssc 07/8/26(日) 1:55 質問
【51050】Re:期間が重複していないか確認する方法 ichinose 07/8/26(日) 22:18 発言
【51052】Re:期間が重複していないか確認する方法 ssc 07/8/26(日) 22:54 質問
【51053】Re:期間が重複していないか確認する方法 ssc 07/8/26(日) 23:15 質問
【51054】Re:期間が重複していないか確認する方法 ichinose 07/8/27(月) 8:04 発言
【51059】Re:期間が重複していないか確認する方法 ssc 07/8/27(月) 9:45 お礼

30983 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free