ＶＢＡでの検索→転記がうまくいかない（削除した時も連動されるようにしたい）

Question

画像のようなカレンダー兼タスクリストを作成中です。
Sheet1にカレンダー、Sheet2にタスクリストを作っています。

左側にタスク番号、右側はプルダウンになっていて、作業が済んだら×をつけるようにしています。
すると、Sheet2にある該当するタスク番号の真下の結合セルに×が転記されるようにしています。

コードは下記のとおりです。

Private Sub Worksheet_Change(ByVal Target As Range) 
  Dim c As Range
  Dim wS As Worksheet
  Dim rng As Range
  
  
    If Intersect(Target, Range("B5:KU103")) Is Nothing Or Target.Count > 1 Then Exit Sub
      With Target
        If .Column Mod 2 = 1 Then
          Set wS = Worksheets("Sheet2")
            Set c = wS.Cells.Find(what:=.Offset(, -1), LookIn:=xlValues, lookAt:=xlWhole)
              If Not c Is Nothing Then 
                c.Offset(1) = .Value
              End If
        End If        
      End With
End Sub 

大きな問題はないのですが、「Sheet1のタスク番号の横の×を残して番号を先に消した時、またはタスク番号と×を同時に消した時」に、「Sheet2に転記された×が残ってしまう」のが少し不便だなと思っています。（×を先に消した時はもちろんSheet2の×も消えます）
どちらを先に消しても転記された×が消えるのがベストなのですが・・・何か良い方法があれば教えて下さい。

追記：sheet2のデータが１０００行以上あるので、関数を使うととても重くなってしまいます。
sheet1には同じタスク番号が入らないことを想定としています。

Comments

[mkk]

これってSheet1には同じタスク番号が入らない想定でしょうか？
それならVBAを使わなくても、関数を使うことで今回の問題も解決しそうですが。

[city_yoshy]

sheet1には同じタスク番号が入らないことを前提としています。
最初は関数で作成していたのですが、1000行程度あるためかなり重くなってしまい、断念してしまいました…

[mkk]

なるほどなるほど・・・
ちなみに関数は何をお使いでしたでしょう？

[city_yoshy]

=IFERROR(INDIRECT("Sheet1!"&ADDRESS(SUMPRODUCT((Sheet1!$A$1:$KU$103=B4)*ROW($A$1:$A$103)),SUMPRODUCT((Sheet1!$A$1:$KU$100=B4)*COLUMN($A$1:$KU$1))+1))&"","")
という式です。

[mattuwan]

＞Sheet1のタスク番号の横の×を残して番号を先に消した時

1）なんで消すんですか？カレンダー側は記録として残しておいた方がよくないですか？
2）タスクtリスト（？）の方は、当日の予定を表示（または指定の日付の予定）を表示するのですか？
ならば、タスクリストの方でのシートで日付を入力し、「その時」にマクロを起動してはいかがでしょうか？
3）いろいろ考えると、タスクリストの方で入力し、カレンダーに反映させた方がよいように思えますが、いかがでしょうか？
あぁ、でも時間が関係ありますか。。。。
でも、タスクリストには時間が表示されませんね。。。。

[city_yoshy]

１）間違えて入力してしまった時などですね…ないとは思うのですが…。データの量が多いので、万が一タスクリストの方に×が残ってしまうと漏れが発生して面倒になってしまうので　です
２）カレンダーを横長につくって、広い範囲のスケジュールを見えるようにしています。
　　当日だけを表示…というのは考えてはいないです
３）　スケジュールがダブらないようにしたいので、カレンダーを基準として管理したいのです

[city_yoshy]

すみません。２）を読み間違えていました。
２）タスクリストは全体を表示するようにしています。特にその日にやるタスクを表示～とかはしていないです。

Answer 1

$KU$103ということは5ヶ月分のリストで6時から22時までということですかね。
確かにそれだと重くなりそうです。
Excel2016以降であればTEXTJOIN関数でSheet1の文字を結合したものを
行毎にカンマ区切りにしてどこかに転記しておき
countifでタスク番号&×が含まれるかで判定すれば軽くなりそうです。

VBAで行うのであれば、Worksheet_SelectionChangeを使って現在の選択範囲の値を記憶するようにし、
削除されたときに記憶してある値で更新をかける方法があります。
後はWorksheet_Changeの際にApplication.Undoで変更前のデータを取得して判定し、
Application.Redoで戻すなども考えられます。

Comments

[city_yoshy]

ありがとうございます。
大変お恥ずかしいのですが、当方エクセル・VBA初心者で、上記のコードも聞きながら教えてもらったものでして…もし可能でしたらもう少し詳しく教えていただけますと幸いです。
またSheet1のデータは、頻繁に編集するような感じなのですが、カンマ区切りで転記する時にはそういった頻繁な編集にも対応できるのでしょうか…
初心者質問で申し訳ないですが、よろしくお願いいたします。

[mkk]

承知しました。
まずはエクセルのバージョンを伺えますか？
バージョンによって取れる手段が変わってくるかと思いますので。

[city_yoshy]

ありがとうございます。
エクセルバージョンは2019です。
お手数おかけいたします。

[mkk]

すいませんもう1点確認です。
sheet1でタスク番号や×が入る可能性がある範囲は
B5～KU103で間違いないでしょうか？

[city_yoshy]

そのとおりです。範囲が変わることは絶対にないので、Ｂ５～ＫＵ１０３固定で大丈夫です。

[mkk]

私の方にExcelの最新版がないので下記の関数が使えないため試していただきたいのですが
sheet2のA1に下記の数式をコピーして入れてみて下さい。
=TEXTJOIN({"",","},FALSE,Sheet1!$B$2:$KU$103)

エラーが出なければ、sheet2のB5セルに下記の数式を入れてみて下さい。
=IFERROR(IF(FIND(B4&"×",$A$1),"×",""),"")

この状態でsheet1でタスク番号101と×を入れたり消したりしてみて動作を確認してみて下さい。
こちらに環境がないため手探りになってしまって申し訳ないですが。

[city_yoshy]

ありがとうございます！
思ったように動きそうです。大変助かりました！