登録内容の確認、上書き

Question

前提・実現したいこと

何度も申し訳ございません。

調べてもわからないのでヒント等教えていただければ幸いです。

ﾕｰｻﾞｰﾌｫｰﾑに登録いうボタンがあるのですが、
そのボタンを押した際、E列を検索し同じ日にちと社員番号があれば
上書きするかの確認と、上書きしてもOKな場合、内容の上書き

登録済のものがなければ新規で登録したいと思っています。

新規の登録の方はうまくいくのですが検索上書きがうまくできません、、

説明がへたくそなためわかりづらく大変申し訳ないのですが解決策等ございましたら
教えていただきたいです。よろしくお願いいたします。

||C|D|E|F|G|H|
|:--|:--:|--:|
|1|予定日|社員番号|=C&E|行先1|行先2|戻時間|
|2|3/10|1234|439001234|新規|登録|しました|
|3|3/11|1234|439011234|新規|登録|しました|
|4|3/12|1234|439021234|新規|登録|しました|
|5|3/13|1234|439031234|新規|登録|しました|

（E列には=C1&E1を相対コピーするコードを書いて入れています）

発生している問題・エラーメッセージ

If Tgtnm = Date1 + i & 1234 Then
Tgtnm.Select
msg = MsgBox("登録済ですが上書きしますか？", Buttons:=vbYesNo)
If msg = vbYes Then
ActiveCell.Offset(0, 1) = "上書き"
ActiveCell.Offset(0, 2) = "され"
ActiveCell.Offset(0, 3) = "ました"
Else
MsgBox "入力を終了します"
End If

上記コードを上書き、検索に使えるだろうと思いコードを書いていったですが
上書きどころか新規での登録もできなくなってしまいました。

間違っているところはここだと思っていますが他にも修正すべき点、解決策や改善策等あれば教えていただきたいです<(_ _)>

該当のソースコード

Sub btm登録()
    Dim Date1 As Date
    Dim Date2 As Date
    Dim i, j, lastRow
    Dim ws As Worksheet
    Dim Tgtnm As Variant
    Dim msg As VbMsgBoxResult
    
    
    Set ws = Worksheets("予定表") 'シートｾｯﾄ    
    
    Date1 = txt予定日.value '例)3/10
    Date2 = txt帰社日.Value '例)3/13
    
    lastRow = ws.Cells(Rows.Count, 3).End(xlUp).Row '一番下の行の取
    ws.Activate 'シートの選択
        
        For i = 0 To DateDiff("d", Date1, Date2)
            For Each Tgtnm In Range("E:E")
                If Tgtnm = Date1 + i & 1234 Then
                    Tgtnm.Select
                    msg = MsgBox("登録済ですが上書きしますか？", Buttons:=vbYesNo)
                        If msg = vbYes Then
                            ActiveCell.Offset(0, 1) = "上書き"
                            ActiveCell.Offset(0, 2) = "され"
                            ActiveCell.Offset(0, 3) = "ました"
                        Else
                            MsgBox "入力を終了します"
                        End If
                Else
                        Cells(i + lastRow + 1, 3) = DateAdd("d", i, Date1)
                        Cells(i + lastRow + 1, 4) = txt社員番号'例)1234
                        Cells(i + lastRow + 1, 5).FormulaR1C1 = Cells(i + lastRow, 5).FormulaR1C1
                        Cells(i + lastRow + 1, 6) = "新規"
                        Cells(i + lastRow + 1, 7) = "登録"
                        Cells(i + lastRow + 1, 8) = "しました"
                End If
            Next
        Next
End Sub
```

### 補足情報（FW/ツールのバージョンなど）
エクセル２０１６

Comments

[sinzou]

案の一つとして、セル値サーチしているときは、上書きするかの判断を行い
上書きなければ新規登録する。

フラグ変数を用意し０値とする
該当セル見つかれば（上書）フラグを１にする
新規登録はFor Each の外でフラグが０であれば行う。

Answer 1

Private Sub CommandButton1_Click()
    Dim rngList As Range
    Dim rngKey As Range
    Dim strBegin As String
    Dim strEnd As String
    Dim ixTop As Long
    Dim ixBottom As Long

    Set rngList = Worksheets("Sheet1").Range("C1").CurrentRegion
    Set rngKey = rngList.Columns("E").Cells
    strBegin = CLng(CDate(Me.TextBox2.Text)) & Me.TextBox1.Text
    strEnd = CLng(CDate(Me.TextBox3.Text)) & Me.TextBox1.Text

    '検索
    On Error Resume Next
    With WorksheetFunction
        ixTop = .Match(strBegin, rngKey, 0)
        ixBottom = .Match(strEnd, rngKey, 0)
    End With
    On Error GoTo 0

    '転記
    If ixTop > 0 Then
        If MsgBox("登録済ですが上書きしますか？", Buttons:=vbYesNo) = vbYes Then
            Application.Range(rngKey(ixTop), rngKey(ixBottom)).Offset(, 1).Value = "更新"
        Else
            MsgBox "キャンセル"
        End If
    Else
        rngKey(rngKey.Count + 1, 2).Resize(ixBottom - ixTop + 1).Value = "新規"
    End If
End Sub

こんな感じですかねぇ。。。

でも、こういうデータの記録の仕方をしたら、
変更があった時、変更前のデータをもれなく探すのが困難ではないでしょうか？
かといっていい代案を思いつかないのですが。。。
たぶん、1行で収めちゃうかなぁ。。。。
あぁ、、、できなくはないのかぁ。。。。。
でも、1行に収めたいような気がする。

Comments

[care_raisu]

難しい、、、！
こんなに見やすく短いコードでできるんですね、、

まだまだ勉強不足な故、使われているものの理解がおいついていません！
すごい！しっかりそれらを使えるほどには勉強してきます。

ありがとうございます。

Answer 2

For Each Tgtnm In Range("E:E")

E列全てをLoopするのはさすがに非効率
あと「txt予定日」「txt帰社日」に日付と判定されない文字列を入れた時のエラー対策とか
かなり先の日付を入力してしまったりした場合に範囲制限するかどうかとか
検討したほうが良いでしょうね

とりあえずセルLoop判定ではなくてMatch関数判定のサンプル

Sub btm登録_Click()
    Dim ws      As Worksheet
    Dim r       As Range
    Dim Date1   As Date
    Dim Date2   As Date
    Dim lastRow As Long
    Dim i       As Long
    Dim key     As String
    Dim x

    Set ws = Worksheets("予定表")    'シートセット
    lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row    '一番下の行の取得
    Set r = ws.Range("E1").Resize(lastRow)

    Date1 = txt予定日.Text    '例)3/10
    Date2 = txt帰社日.Text    '例)3/13

    For i = 0 To DateDiff("d", Date1, Date2)
        '検索key文字列をつくり
        key = CLng(Date1 + i) & txt社員番号.Text
        'Match関数で登録有無を調べる
        x = Application.Match(key, r, 0)
        If IsError(x) Then
            '無ければ新規
            With ws.Cells(ws.Rows.Count, 3).End(xlUp)
                .Offset(1, 0).Value = DateAdd("d", i, Date1)
                .Offset(1, 1).Value = txt社員番号.Text '例)1234
                .Offset(1, 2).FormulaR1C1 = "=RC[-2]&RC[-1]"
                .Offset(1, 3).Value = "新規"
                .Offset(1, 4).Value = "登録"
                .Offset(1, 5).Value = "しました"
            End With
        Else
            If MsgBox("登録済ですが上書きしますか？", Buttons:=vbYesNo) = vbYes Then
                With ws.Cells(x, 6)
                    .Offset(, 0).Value = "上書き"
                    .Offset(, 1).Value = "され"
                    .Offset(, 2).Value = "ました"
                End With
            Else
                MsgBox "入力を終了します"
            End If
        End If
    Next
End Sub

Comments

[care_raisu]

match関数を使うことを思いつきませんでした、、

テキストBOXの方にはカレンダーフォームを設置し、
そこから選んでもらうようにしてはあるので判定されない文字の入力はされないと信じたいのですが
かなり先の日付に対しては盲点でしたので
単純ですがIFとmsgboxを使い今日の日付から１か月の入力のみ有効とできるよう設定できるようにします。

また使ったことのない関数がたくさんありますので一度調べてどういう働きをしているのか確認してみます。

大変勉強になりました。ありがとうございます！