[[20211213141600]]　『期限切れの名称表示および日付の更新』（マカロニ）　ページの最後に飛ぶ

『期限切れの名称表示および日付の更新』（マカロニ）

こんにちは。
どうにもこうにも上手く動作ができず作業が進まなくて困っているため、
教えていただけたら幸いです。

【台帳の記載内容】
range("B3")に今日の日付(=TODAY())を表示
・A列に名称、H列に更新前の日付、I列に最新の日付

【ユーザーフォームの設定】
・Label1～Label10、TextBox1～TextBox10を設置し、
Range("B3")の日付よりも超過した日付(H列)の名称(A列)を
Lavelに表示させ、更新後の日付をTextBoxに直接入力

・ユーザーフォーム内に設置された更新ボタン(CommandButton1)を押すと、
Labelに表示された名称と一致した行のセル(I列)にTextBoxに入力した日付を自動入力

・超過がゼロの場合はmsgbox"期限切れはありません"と表示

Dim xlLastRow As Long
Dim Max_Score As Long
Dim Last_Row As Variant
Dim i As Long

Max_Score = Range("B3") '今日の日付

xlLastRow = Cells(Rows.Count, 1).Row 'Excelの最終行を取得
Lastrow1 = Cells(xlLastRow, 8).End(xlUp).Row 'H列最終行

For i = 16 To Lastrow1 '15行目が見出しで16行目から一覧が表示

If Cells(i, 8) >= Max_Score Then 'もしHの列の日付がtodayを過ぎてたら

・
・
・
・
・

msgbox"期限切れはありません"
unload me

該当名称全てをLabelに表示させていき、TextBoxに入力した日付を台帳へ更新するコードを教えて頂けたらと思います。

以上、宜しくお願いします。

＜使用 Excel：Office365、使用 OS：unknown ＞

Label,TextBoxが10づつですが、
更新するものが10以上だったら
どうするんですか？

私なら、Label1,TextBox1のみにして、
期限切れが無くなるか、キャンセル処理が入るまで、
ループさせる、と思います。

（tkit） 2021/12/13(月) 15:32

コメントありがとうございます。

毎月チェックしなければならない台帳により、
10以上入ることはないと過去の経験から設置に上限を10としています。

また、10以上になった際は、
msgboxで"10以上あるため、表示不可能"を検討しています。
（マカロニ） 2021/12/13(月) 15:53

＞過去の経験から設置に上限を10としています。
分かりました。

案だけですが、
配列または連想配列に期限切れの名前、行を代入しておきますね。
まぁご自身で考えてみてください。
（tkit） 2021/12/13(月) 17:14

ありがとうございます。
提案を基に作成してみます。
（マカロニ） 2021/12/14(火) 11:07

 ユーザーフォームを、呼び出し時に
 Initializeで名称を表示させるって事ですよね？

 因みに、名称についてですが重複はありませんか？
（あみな） 2021/12/14(火) 12:17

コメントありがとうございます。
＞ユーザーフォームを、呼び出し時に

 Initializeで名称を表示させるって事ですよね？
＞＞はい。 Initializeで項目を表示させてます。

＞因みに、名称についてですが重複はありませんか？
＞＞重複はありません。
（マカロニ） 2021/12/14(火) 12:57

 >項目を表示させています。

 超過日付を基に、名称は表示てきてるのですね？
 そこまで出来るなら後も出来そうな気がするんだが(-∀-)

（あみな） 2021/12/14(火) 13:48

Dim LastRow As Long
Dim TargetDay As Long
Dim 期限 As String
Dim i As Long

    '最終行取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    '日付
    TargetDay = Range("B3")

    '行ループ
    For i = 16 To LastRow

        '指定の期限が切れている場合、変数にデータを格納
        If Cells(i, 8) < TargetDay Then
            期限 = 期限 & Cells(i, 1)
        End If

    Next i

    If 期限 = "" Then
        MsgBox "期限切れはありません。"
        Unload Me
    Else

【条件コード】

    end if

end sub

1,期限切れの名称を”期限”に格納し、ラベルに表示する。
2,テキストボックスに日付を入力し、”期限”と一致した行の台帳H列へ抽出
3,unload me

一日考えましたが、どうにもうまく動作しません。
教えて頂けないでしょうか。

（マカロニ） 2021/12/15(水) 10:16

当該の行も記録しないと、変更後の反映ができませんよ。
（きまぐれおじさん） 2021/12/15(水) 10:43

 とりあえず、Initializeでラベルとテキストに期限切れを表示するコード例
 該当する行番号をテキストボックスのTagプロパティに格納するようにしました。

 ---- 
Private Sub UserForm_Initialize()
    Dim LastRow As Long
    Dim TargetDay As Long
    Dim cnt As Long
    Dim i As Long
    '最終行取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    '日付
    TargetDay = Range("B3")
    '行ループ
    For i = 16 To LastRow
        '指定の期限が切れている場合、変数にデータを格納
        If Cells(i, 8) < TargetDay Then
            cnt = cnt + 1
            Me.Controls("Label" & cnt).Caption = Cells(i, 1)
            Me.Controls("TextBox" & cnt).Value = Cells(i, 8)
            Me.Controls("TextBox" & cnt).Tag = i
        End If
    Next i
    If cnt = 0 Then
        MsgBox "期限切れはありません。"
        Unload Me
    End If
End Sub

（hatena） 2021/12/15(水) 10:59

 Dim rList() As Long
 Dim LastRow As Long
 Dim TargetDay As Long
 Dim ListCount
 Dim i As Long
    '最終行取得
    LastRow = Cells(Rows.count, 1).End(xlUp).row
    '日付
    TargetDay = Range("B3").Value2  '※シリアル値を代入するならValue2
    '行ループ
    For i = 16 To LastRow
        '指定の期限が切れている場合、変数にデータを格納
        If Cells(i, 8).Value2 < TargetDay Then
            ReDim Preserve rList(ListCount)
            rList(ListCount) = i                '行の情報からあとでH列とA列の値は取得できるので行の値だけ配列に入れる
            ListCount = ListCount + 1
        End If
    Next i
    If ListCount < 1 Then
        MsgBox "期限切れはありません。"
        Unload Me
    Else
【条件コード】
    End If

気づいた点を直すとこんな感じでしょうか

（きまぐれおじさん） 2021/12/15(水) 11:03　※11:14修正

 コマンドボタンでテキストボックスの更新をシートに反映させるコードも追加しました。

 ---
Option Explicit
Dim cnt As Long
Private Sub CommandButton1_Click()
    Dim i As Long
    For i = 1 To cnt
        With Me.Controls("TextBox" & i)
            Cells(.Tag, 8) = .Value
        End With
    Next
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim LastRow As Long
    Dim TargetDay As Long
    Dim i As Long
    '最終行取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    '日付
    TargetDay = Range("B3")
    '行ループ
    For i = 16 To LastRow
        '指定の期限が切れている場合、変数にデータを格納
        If Cells(i, 8) < TargetDay Then
            cnt = cnt + 1
            Me.Controls("Label" & cnt).Caption = Cells(i, 1)
            Me.Controls("TextBox" & cnt).Value = Cells(i, 8)
            Me.Controls("TextBox" & cnt).Tag = i
        End If
    Next i
    If cnt = 0 Then
        MsgBox "期限切れはありません。"
        Unload Me
    End If
End Sub

（hatena） 2021/12/15(水) 11:13

お二方教えて頂きありがとうございます。

コードを記述しても動作がうまくいかないため、
一晩考えてわからなかかったら再度こちらに書き込みさせて頂きます。
（マカロニ） 2021/12/15(水) 16:47

 ＞・ユーザーフォーム内に設置された更新ボタン(CommandButton1)を押すと、
 ＞Labelに表示された名称と一致した行のセル(I列)にTextBoxに入力した日付を自動入力

 ↑最初と

 ↓後日では更新後の日付を入力する列が違うけども...調整はご自由に

 ＞2,テキストボックスに日付を入力し、”期限”と一致した行の台帳H列へ抽出

 Match でやってみました。どうでしょうか？...調整はご自由にどぞ

 Option Explicit
 Private Sub UserForm_Initialize()

    Dim today As Date
    Dim i, cnt As Long
    Dim MaxRow As Long
    Dim ws As Worksheet
    Dim x As String, tmp As String
    Dim Overdue(1 To 10) As String '' 期限切れ Overdue or Expired
    Set ws = Sheets(1)
    Const START_COL = 8&
    today = Date
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row

    On Error GoTo Err '' 期限切れが、10件以上の対策
    For i = 16 To MaxRow
            If IsDate(Cells(i, START_COL).Value) Then
                    x = Cells(i, START_COL).Value
                    If x <= Range("B3").Value Then '' Range("B3").Value をtodayで代替可
                            cnt = cnt + 1
                            Overdue(cnt) = Cells(i, START_COL).Address _
                            (RowAbsolute:=False, ColumnAbsolute:=False)
                            Me.Controls("Label" & cnt).Caption = Cells(i, START_COL).Offset(, -7)
                    End If
            End If
    Next

    If cnt <> 0 Then
            For i = 1 To cnt
                    tmp = tmp & Overdue(i) & vbCrLf
            Next
                    MsgBox "期限切れがあります" & vbCrLf _
                    & tmp, vbInformation
            Else: MsgBox "期限切れはありません"
    End If
    Exit Sub
 Err:
                    MsgBox "期限切れが、10件以上あります"
                    Err.Clear
 End Sub
 Private Sub CommandButton1_Click()

    Dim i As Long
    Dim MaxRow As Long
    Dim ws As Worksheet
    Dim x As String, tmp As String
    Const START_COL = 8&
    Set ws = Sheets(1)
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row
    For i = 1 To 10 '' Label1～Label10、TextBox1～TextBox10の設置数分のみTextBoxから更新後の日付を入力
            x = Me.Controls("Label" & i).Caption
            tmp = WorksheetFunction.Match(x, Range("A16:A" & MaxRow), 0)
            ws.Range("I" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")
    Next
    Unload Me

 End Sub
（あみな） 2021/12/15(水) 17:00

あみな様、コードのご教授ありがとうございます。

TODAYより過ぎた日付を探す列　…　I
更新後の日付を入力する列　…H

＜今回追加のご質問＞
破棄または保管など特定の文字が入力される列　…　L

上記のコードに追加で、特定の文字がL列に文字が入力されたら、
期限が過ぎていてもLabelに表示させない。としたいです。

ご質問ばかりで申し訳ありません。
教えて頂いたコードが難しく、読み解くことができず再びご質問させてください。
よろしくお願いします。
（マカロニ） 2021/12/23(木) 09:48

今更ですが、Inputbox案を提示します。
標準モジュールに貼り付けて、実行してみてください。
UserFormに拘らず、試してみてください。
コードは割とスッキリしてると思いますし、
日本語で分かりやすくしたつもりです。
コンパイルチェックのみしか確認していませんので、あしからず。

 Option Explicit

 'モジュールレベル定数
 Private Const 名称列 As Long = 1 'A列
 Private Const 日付列 As Long = 9 'I列
 Private Const 更新列 As Long = 8 'H列
 Private Const チェック列 As Long = 12 'L列
 Private Const 開始行 As Long = 16
 Private Const 特定文字列群 As String = "破棄,保管"

 Public Sub 期限切れチェック()
     Dim sht As Worksheet
     Set sht = ThisWorkbook.Worksheets(1)

     Dim 最終行 As Long
     最終行 = 日付列の最終行取得(sht)

     Dim 期限切れ行 As Collection
     Set 期限切れ行 = 期限切れ行取得(sht, 最終行)

     If 期限切れ行.Count = 0 Then
         MsgBox "期限切れがありません。終了します。", vbInformation
         Exit Sub
     End If

     Dim 入力値 As String
     Dim 行 As Variant
     For Each 行 In 期限切れ行
         Do
             入力値 = InputBox(表示メッセージ(sht, 行))
             Select Case True
             Case 入力値 = vbNullString:             Exit For 'キャンセル
             Case Not IsDate(入力値):                MsgBox "日付ではありません", vbExclamation
             Case DateDiff("d", 入力値, Now()) < 0:  MsgBox "期限切れです", vbExclamation
             Case Else:                              Exit Do
             End Select
         Loop
         sht.Cells(行, 更新列).Value = 入力値
     Next
 End Sub

 Private Function 日付列の最終行取得(ByVal sht As Worksheet) As Long
     日付列の最終行取得 = sht.Cells(sht.Rows.Count, 日付列).End(xlUp).Row
 End Function

 Private Function 期限切れ行取得(ByVal sht As Worksheet, ByVal 最終行 As Long) As Collection
     Dim i As Long
     Dim n As Long
     Dim セル値 As String
     Dim c As New Collection
     For i = 開始行 To 最終行
         If 特定文字列チェック(sht.Cells(i, チェック列).Value) = False Then
             セル値 = sht.Cells(i, 日付列).Value
             If IsDate(セル値) Then
                 n = DateDiff("d", セル値, Now())
                 If n > 0 Then
                     c.Add n
                 End If
             End If
         End If
     Next
     Set 期限切れ行取得 = c
 End Function

 Private Function 表示メッセージ(ByVal sht As Worksheet, ByVal 表示行 As Long) As String
     Dim msg As String
     msg = "日付を更新してください。" & vbCrLf & _
           "名称：" & sht.Cells(表示行, 名称列).Value & vbCrLf & _
           "日付：" & sht.Cells(表示行, 日付列).Value
     表示メッセージ = msg
 End Function

 Private Function 特定文字列チェック(ByVal チェックする文字列 As String) As Boolean
     Dim flg As Boolean
     Dim 特定文字列 As Variant
     For Each 特定文字列 In Split(特定文字列群, ",")
         If 特定文字列 = チェックする文字列 Then
             flg = True
             Exit For
         End If
     Next
     特定文字列チェック = flg
 End Function

（tkit） 2021/12/23(木) 11:57

 ＞今回追加のご質問

 追加でする事は、簡単です。					
 （tkit）さんが書いてくださったコードの一部からヒントを探して					
 IF文を追加して…「 ちょちょちょいっ 」とするだけです。 (-∀-)

 ＞教えて頂いたコードが難しく、読み解くことができず再びご質問させてください

 以前にここの回答者の大先輩が言っていた事ですが…					
 理解できないコードは使用してはいけません。と厳しくおっしゃっていました。

 なので…ご自身で多分「 こ～して。。。あ～すれば 」できそうな処まで					
 コードを追加してみてください。間違っていてもそれは大丈夫なので					
 出来たら掲示してください。エラーで動かなくても良いので、努力する事が重要です。					
 因みに、修正するのは...UserForm_Initialize　の方だけです。

 と...CommandButton1_Clickの方のコードを一部修正しました。

 Private Sub CommandButton1_Click()

    Dim i As Long					
    Dim MaxRow As Long					
    Dim ws As Worksheet					
    Dim x As String, tmp As String					
    Const START_COL = 1&					
    Set ws = Sheets(1)					
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row					
    For i = 1 To 10					
            If Me.Controls("Label" & i).Caption <> "" Then					
                    x = Me.Controls("Label" & i).Caption					
                    tmp = WorksheetFunction.Match(x, Range("A16:A" & MaxRow), 0)					
                    ws.Range("I" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")					
            End If					
    Next					
    Unload Me

 End Sub

 では、また数日後に…頑張ってください o(*'▽'*)/

（あみな） 2021/12/23(木) 20:50

 ＞TODAYより過ぎた日付を探す列　…　I
 ＞更新後の日付を入力する列　…H

 ・よ～く見ていませんでした。上記で確定ですね。

 間違い
 ws.Range("I" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")

 訂正
 ws.Range("H" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")

 ・UserForm_Initialize　の方はご自身で調整して出来たって事ですね？

（あみな） 2021/12/24(金) 14:00

tkit様、ご提案とコードの記述ありがとうございます。

Inputboxを初めて知りました。
ユーザーフォームでどうにかしようとしなくても上記コードで期限切れおよび
セルへの転写ができるんですね。
提案および丁寧なコードをありがとうございます。

上記コードを標準モジュールに張り付けてみたところ、
期限切れの確認は問題なく実行できました。
ありがとうございます。
ですが、
msg = "日付を更新してください。" & vbCrLf & _

      "名称：" & sht.Cells(表示行, 名称列).Value & vbCrLf & _
      "日付：" & sht.Cells(表示行, 日付列).Value

のコードを実行すると
sht.Cells(表示行, 名称列)およびsht.Cells(表示行, 日付列)が表示されません。
また、sht.Cells(行, 更新列).Value の入力先のセルがH712となってしまい、
該当の名称列(A列)のH列へ入力されません。

上記で述べた通り、Inputboxを初めて知ったので、
これから内容を読み解いていきます。
また何か不明点がありましたら再びこちらにてご質問させてください。

以上、よろしくお願いします。

（マカロニ） 2021/12/24(金) 15:38

あみな様、再びのコメントありがとうございます。

理解できないコードは使用してはいけません。>>>激しく同意しました。
その通りですね！！！
なので、
＜今回追加のご質問＞
破棄または保管など特定の文字が入力される列　…　L
を無くします！！！！
入力があればその行を別シートへ自動的に切り取って画面上もスッキリ！！！！！
という
Private Sub Worksheet_Change(ByVal Target As Range)
にてコードを記述しました。

ただ、再びのご質問で大変恐縮なのですが、
Format(Me.Controls("TextBox" & i), "yyyy/m/d") にて
日付を入力していない状態で実行すると、
"Label"と一致した行のH列が空白として処理されてしまい、
もともと入力されていた日付が消えてしまいます。。。
こちらもif文でIf textbox_value = "" Thenとして
分岐すればよろしいのでしょうか。

何度も何度も申し訳ございません。
再びコードとにらめっこしてきます。

（マカロニ） 2021/12/24(金) 15:51

 ＞sht.Cells(表示行, 名称列)およびsht.Cells(表示行, 日付列)が表示されません。

 原因が分かりました。
 期限切れ行取得に問題がありました。
 行数を取得すべきところ、日付差を取得していました。
 修正して確認してください。

（tkit） 2021/12/24(金) 17:02

 ・課題Aとする

 ＞破棄または保管など特定の文字が入力される列　…　L
 ＞を無くします！！！！

 あら？変更しちゃったのですね。
 L列はあっても良い気がするんですけどね？

 使用者の画面前部が見えないので断定はできませんが...
 ま～一様L列がある場合を書いたので上げます。

 ・課題Bとする

 ＞日付を入力していない状態で実行すると、
 ＞"Label"と一致した行のH列が空白として処理されてしまい、
 ＞もともと入力されていた日付が消えてしまいます。。。

 うん、そうですね。そこをど～するんかなと？
 質問をしようとしてました。

 L列がある場合の完成コード（ 課題A ）と、（ 課題B ）用回避の途中まで & Sample付の
 のコードを掲示します。

 尚、Sampleは、他のSample1～8も付録で付いてます。（ 笑 ）
 指定日付けのI列が多いと、Sample1　の実行は大変かもですが
 BOOKを複製して、行を20行程度にしてSample1～7を試してみてください。

 ※L列が破棄となっていた為、行削除をするコードも付録であります。
 行を削除は、質問が追加で来そうなので先回りしました。(-∀-)
 テストは必ずBOOKを複製して、試してみてください。

 今から外食の準備と、今夜はお酒が入るのでもう何もできません。(〃'∇'〃)ゝｴﾍﾍ
 年末で明日から忙しいので出来るかわかりませんが...ご自身でもトライしてみてください。

 ちょっと長くなりますが...

 ◇（ 課題A ）L列がある場合の完成コード

 Private Sub UserForm_Initialize()

    Dim i, cnt As Long
    Dim MaxRow As Long
    Dim ws As Worksheet
    Dim x As String, tmp As String, Lp As String
    Dim Overdue(1 To 10) As String
    Set ws = Sheets(1)
    Const START_COL = 9&
    Const First_Condition As String = "破棄"
    Const Second_Condition As String = "保管"
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row

    On Error GoTo Err
    For i = 16 To MaxRow
            If IsDate(Cells(i, START_COL).Value) Then
                    x = Cells(i, START_COL).Value
                    Lp = Cells(i, START_COL).Offset(, 3).Value
                    If x <= Range("B3").Value Then
                            If First_Condition <> Lp And Second_Condition <> Lp Then
                            cnt = cnt + 1
                                    Overdue(cnt) = Cells(i, START_COL).Address _
                                    (RowAbsolute:=False, ColumnAbsolute:=False)
                                    Me.Controls("Label" & cnt).Caption = Cells(i, START_COL).Offset(, -8)
                            End If
                    End If
            End If
    Next

    If cnt <> 0 Then
            For i = 1 To cnt
                    tmp = tmp & Overdue(i) & vbCrLf
            Next
                    MsgBox "期限切れがあります" & vbCrLf _
                    & tmp, vbInformation
            Else: MsgBox "期限切れはありません"
    End If
    Exit Sub
 Err:
                    MsgBox "期限切れが、10件以上あります"
                    Err.Clear
 End Sub

 ◇（ 課題B ）用回避の途中までコード

 Private Sub UserForm_Initialize() '' Sample_1～4

    Dim i, cnt As Long
    Dim MaxRow As Long
    Dim ws As Worksheet
    Dim RetMsg As VbMsgBoxResult '' Sample_4 用変数追記
    Dim x As String, tmp As String, Lp As String
    Dim Overdue(1 To 10) As String '' 期限切れ
    Set ws = Sheets(1)
    Const START_COL = 9&
    Const First_Condition As String = "破棄"
    Const Second_Condition As String = "保管"
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row

    On Error GoTo Err
    For i = 16 To MaxRow
            If IsDate(Cells(i, START_COL).Value) Then
                    x = Cells(i, START_COL).Value
                    Lp = Cells(i, START_COL).Offset(, 3).Value
                                    '' Sample_1
                                    ' MsgBox x '' ステップ実行の替り
                    If x <= Range("B3").Value Then
                            If First_Condition <> Lp And Second_Condition <> Lp Then
                            cnt = cnt + 1
                                    '' Sample_2
                                    ' MsgBox cnt
                                    Overdue(cnt) = Cells(i, START_COL).Address _
                                    (RowAbsolute:=False, ColumnAbsolute:=False)
                                    Me.Controls("Label" & cnt).Caption = Cells(i, START_COL).Offset(, -8)
                                    '' Sample_3
                                    ' Debug.Print x '' 期限切れ日付けを、イミディエイトウィンドウへ表示(抽出)
                            End If
                    End If
            End If
    Next
                    RetMsg = MsgBox _
                    (" L列に、''破棄''と記載されていますが" & vbCrLf & _
                    " どうしますか？" & vbCrLf & _
                    vbCrLf & _
                    " 『 はい 』 を押すと､行を一括削除します" & vbCrLf & _
                    " 『 いいえ 』 を押すと、何もしません", vbYesNo + vbInformation, Title:="INFO")
                    Select Case RetMsg
                            Case vbYes
                                    '' Sample_4 ''Callして、標準モジュールへ( First_Condition=''破棄'' )をByValで値を渡す
                                    Call Bulk_Deletion(First_Condition) '' ''破棄''の入力された行を一括削除
                            Case vbNo
                    End Select

    If cnt <> 0 Then
            For i = 1 To cnt
                    tmp = tmp & Overdue(i) & vbCrLf
            Next
                    MsgBox "期限切れがあります" & vbCrLf _
                    & tmp, vbInformation
            Else: MsgBox "期限切れはありません"
    End If
    Exit Sub
 Err:
                    MsgBox "期限切れが、10件以上あります"
                    Err.Clear
 End Sub

 Private Sub CommandButton1_Click() '' Sample_5～8

    Dim i As Long
    Dim MaxRow As Long
    Dim ws As Worksheet
    Dim ChangeData As String            '' Sample_7 用変数追記
    Dim x As String, tmp As String
    Dim RetMsg As VbMsgBoxResult '' Sample_8 用変数追記
    Const START_COL = 1&
    Set ws = Sheets(1)
    MaxRow = ws.Cells(Rows.Count, START_COL).End(xlUp).Row

                    RetMsg = MsgBox _
                    (" H列を '' 更新 '' しますが、TextBox に入力が無いと...？？？" & vbCrLf & _
                    " 以前に入力された '' 更新日付け '' が空白になりますが、どうしますか？" & vbCrLf & _
                    vbCrLf & _
                    " 『 はい 』 を押すと､H列の日付けを更新します" & vbCrLf & _
                    " 『 いいえ 』 を押すと、H列に日付けが入力されている箇所は更新しません" & vbCrLf & _
                    vbCrLf & _
                    " 『 キャンセル 』 を押すと、何もしません", _
                    vbYesNoCancel + vbInformation, Title:="INFO")

                    Select Case RetMsg
                            Case vbYes
                                    For i = 1 To 10
                                            If Me.Controls("Label" & i).Caption <> "" Then
                                                    x = Me.Controls("Label" & i).Caption
                                                    tmp = WorksheetFunction.Match(x, Range("A16:A" & MaxRow), 0)
                                                    ws.Range("H" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")
                                                    '' Sample_5  '' 対象行を検索 '' 範囲内の行を1行目として数える
                                                    ' MsgBox tmp
                                                    '' Sample_6 '' 検索値の行を、イミディエイトウィンドウへ表示
                                                    ' Debug.Print tmp + 15
                                                    '' Sample_7 '' TextBoxへ日付けを入力後に一括変更
                                                    ' ChangeData = Format(Me.Controls("TextBox" & i), "yyyy/m/d")
                                                    ' MsgBox ChangeData
                                            End If
                                    Next
                                                    Unload Me
                            Case vbNo
                                                    '' Sample_8 ''
                                                    Call Sample_8
                            Case vbCancel
                                                    MsgBox "さようなら"
                                                    Unload Me
                    End Select

 End Sub

 ▼標準モジュールへ

 Option Explicit
 Sub Bulk_Deletion(ByVal First_Condition As String)
    '' Sample_4 '' 変数の『 First_Condition 』に、格納されている内容を確認する
    MsgBox First_Condition
    Dim i As Long
    Dim MaxRow As Long
    MaxRow = Cells(Rows.Count, 12).End(xlUp).Row
    Application.DisplayAlerts = False
    With ActiveSheet
            For i = MaxRow To 16 Step -1
                    If InStr(Cells(i, 12), First_Condition) >= 1 Then '行削除
                            .Rows(i).Delete
                    End If
            Next
    End With
    Application.DisplayAlerts = True
 End Sub
 Sub Sample_8()
    MsgBox "できるかにゃ？"　ここに回避用を作成する
　　　　　　　　　　　　　　 もしくはCommandButton1_Clickの方にするか？
 End Sub

 ※Sample は、コメントアウトを外して実行をしてみてください。
 尚、既に理解しているのであればする必要はありませ～ん。

 ※と標準モジュールへの分岐は、ユーザーフォームばっかりだと
 コードがいっぱいになってしますので標準モジュールさんに応援してもらうだけです。

（あみな） 2021/12/24(金) 17:27

 ＞こちらもif文でIf textbox_value = "" Thenとして					
 ＞分岐すればよろしいのでしょうか。

 昨日の続きです。					
 Private Sub CommandButton1_Click()　の回避編(抜粋)

 Select Case RetMsg
        Case vbYes
                For i = 1 To 10 '' セルに入力済みの日付けは削除されるコード
                        If Me.Controls("Label" & i).Caption <> "" Then
                                x = Me.Controls("Label" & i).Caption
                                tmp = WorksheetFunction.Match(x, Range("A16:A" & MaxRow), 0)
                                ws.Range("H" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")
                        End If
                Next
                        Unload Me
        Case vbNo
                For i = 1 To 10 '' TextBox に入力が無い場合は、セルに反映させないコード
                        If Me.Controls("Label" & i).Caption <> "" Then
                                x = Me.Controls("Label" & i).Caption
                                tmp = WorksheetFunction.Match(x, Range("A16:A" & MaxRow), 0)
                                If Me.Controls("TextBox" & i).Value <> "" Then
                                        ws.Range("H" & tmp + 15).Value = Format(Me.Controls("TextBox" & i), "yyyy/m/d")
                                End If
                        End If
                Next
                        Unload Me
        Case vbCancel
                MsgBox "さようなら"
                Unload Me
 End Select

 基本これでもいいのだけれども…う～んなんか美しくない(笑)					
 あっ、勿論MsgBoxで分岐する必要もないので、とっぱらって使用してもらえばいいのですが

 と言うことで…もういっちょ					
 UserForm_Initialize　へH列の日付けの更新が入っている場合は、TextBox へ反映させて					
 TextBox　が空白なら、まだ更新日を入力されてないのがスグに判る方が使い勝手が良いのでは					
 ないかと考えるのですがどうでしょうか？

 入力されているセルの日付けは、ボタンを押すともう1っ回擦ることになりますが

 一行追加するだけです。					
 Me.Controls("TextBox" & cnt).Value = Format(Cells(i, START_COL).Offset(, -1), "yyyy/m/d")

 ではでは...頑張って検証してみてください o(*'▽'*)/

（あみな） 2021/12/25(土) 22:01

あみな様、多くのご教授ありがとうございます！！！

    For i = 16 To MaxRow
            If IsDate(Cells(i, START_COL).Value) Then
                    x = Cells(i, START_COL).Value
                    Lp = Cells(i, START_COL).Offset(, 3).Value
                    If x <= Range("B3").Value Then
                            If First_Condition <> Lp And Second_Condition <> Lp Then
                            cnt = cnt + 1

☆ Me.Controls("TextBox" & cnt).Value = Format(Cells(i, START_COL).Offset(, -1), "yyyy/m/d")

                                    Overdue(cnt) = Cells(i, START_COL).Address _
                                    (RowAbsolute:=False, ColumnAbsolute:=False)
                                    Me.Controls("Label" & cnt).Caption = Cells(i,START_COL).Offset(, -8)
                            End If
                    End If
            End If
    Next

ご提案して頂いた通り、ユーザーフォームを立ち上げたときに既に日付をテキストボックスへ表示させるコードを追加【☆】したことで、空白になる問題は無事解決しました！！

あと一つ最後になりますが、

Private Sub UserForm_Initialize()

…処理…

Else: MsgBox "期限切れはありません"
End If
Exit Sub

とあります。
期限切れが無いときは、ユーザーフォームを立ち上げず強制終了するコードを作成しました。

Else: MsgBox "期限切れはありません"
Call マクロ終了

・標準モジュール
Sub マクロ終了()
End
End Sub

標準モジュールのプロシージャを呼び出しで、
動作を終了にしています。
コードの入力はスマートではないと思いますが、
なんとかユーザーフォームが立ち上がらずmsgboxが表示されて終了することができました。

長々と年度をまたいでまでお付き合いして頂きありがとうございました。
（マカロニ） 2022/01/05(水) 14:26

 ＞コードの入力はスマートではないと思いますが、					
 ＞なんとかユーザーフォームが立ち上がらずmsgboxが表示されて終了することができました。

 ご自身の使いやすさの重視と、マクロを動かす事が重要なので、それでOKです。					
 自分でこれが良いなと思うことをすれば基本…大丈夫ですよ。

 でも...End これ一行だけ？ならそのまま下記の方が多分良いかなと					
 思います。

 Else: MsgBox "期限切れはありません"					
 End ←これだけで

 個人差はあると思いますが、標準モジュールさんの応援は十行以上とか？					
 別処理の場合で分けた方が理解し易いとか、Functionだけにされた方が					
 良いかと思います。

 私も、スキルが足りないので…なんとなくそう思うだけですが…^^;

 と【☆】のコードはど真ん中にいれたのですかね？					
 …使用人の好きなところへでOKなのですが					
 cnt = cnt + 1　のすぐ下？

 動きには、支障がないので良いですけど

 cnt = cnt + 1					
   Overdue(cnt) = Cells(i, START_COL).Address _					
   (RowAbsolute:=False, ColumnAbsolute:=False)					
   Me.Controls("Label" & cnt).Caption = Cells(i, START_COL).Offset(, -8)					
   Me.Controls("TextBox" & cnt).Value = Format(Cells(i, START_COL).Offset(, -1), "yyyy/m/d")					
End If

 上記の方が、Me.Controlsを2行にして、右辺を左辺にが並んだ方が個人的には					
 可読性も良く、綺麗かなと思いますです。(きっと^^;)

 ではでは、お疲れさまでした。

（あみな） 2022/01/05(水) 23:06

コメント返信：

[ 一覧(最新更新順) ]

[[20211213141600]] 『期限切れの名称表示および日付の更新』（マカロニ） ページの最後に飛ぶ

[[20211213141600]]　『期限切れの名称表示および日付の更新』（マカロニ）　ページの最後に飛ぶ