[[20171225133904]]　『Activesheet.protectについて』（もち）　ページの最後に飛ぶ

『Activesheet.protectについて』（もち）

VBAで日付の入力とシートの保護・解除をしようとしています。
基本はシート保護されておりQ列、T列は保護されておらず入力可能な状態で
処理としては以下のイメージです。

Q(T)列に入力
シート保護解除
R(U)列に入力日付を入力
シート再保護

Q列はオートフィルで一気に更新する時もあり
その際すべてのR列が更新されないといけません。

この状態ではシートの再保護ができません。
どうすれば良いでしょうか。

'1段目
Private Sub Worksheet_Change(ByVal Target As Range)
'複数のPrivate Subを使用
Worksheet_Change_1 Target '2段目の処理用
Worksheet_Change_2 Target '3段目の処理用
End Sub

'2段目
Private Sub Worksheet_Change_1(ByVal Target As Range) '←Worksheet_Changeの中で使っている名前と合わす
'Q列に入力があるとR列に入力日付を自動挿入します
'オートフィル対応
Dim myRng As Range
Dim r As Range
Set myRng = Intersect(Target, Range("Q:Q")) '←Q列が更新されたとき
ActiveSheet.Unprotect 'シート保護解除
If myRng Is Nothing Then Exit Sub

For Each r In myRng
If r.Value = "" Then
Cells(r.Row, 18).Value = "" '←18列目（R列)
Else
Cells(r.Row, 18).Value = Date '←18列目（R列）に日付を入力
ActiveSheet.Protect 'シート保護
End If
Next
End Sub

'3段目
Private Sub Worksheet_Change_2(ByVal Target As Range) '←Worksheet_Changeの中で使っている名前と合わす
'T列に入力があるとU列に入力日付を自動挿入します
'オートフィル対応
Dim myRng As Range
Dim r As Range
Set myRng = Intersect(Target, Range("T:T")) '←T列が更新されたとき
ActiveSheet.Unprotect 'シート保護解除
If myRng Is Nothing Then Exit Sub

For Each r In myRng
If r.Value = "" Then
Cells(r.Row, 21).Value = "" '←21列目（U列)
Else
Cells(r.Row, 21).Value = Date '←21列目（U列）に日付を入力
ActiveSheet.Protect 'シート保護
End If
Next
End Sub

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

されたいことってこんなことです？

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Protect

 　If Not Application.Intersect(Target, Range("Q:Q")) Is Nothing Or _
      Not Application.Intersect(Target, Range("T:T")) Is Nothing Then
        Target.Offset(0, 1).Value = Date
   End If
ActiveSheet.Unprotect
End Sub

ただ、便利機能として
ActiveSheet.Protect UserInterfaceOnly:=True
としてやれば、ユーザー操作は保護されて制限されるけど、マクロからの操作は保護の影響を受けないって方法もあります。（ワークブック開き直すと、普通の保護に変わるみたいですけど）
（もこな２） 2017/12/25(月) 14:40

Unprotect　と　Protect　逆ですね、
すみません。
（もこな２） 2017/12/25(月) 14:42

度々すみません。ちょっと修正です。
Private Sub Worksheet_Change(ByVal Target As Range)
'Q又はT列を含む複数列を一気に変更されると不具合が起きるので
'変更セル範囲が２列以上ある場合は、動作させないようにしました。
If Target.Columns.Count > 1 Then Exit Sub

ActiveSheet.Unprotect

   If Not Application.Intersect(Target, Range("Q:Q")) Is Nothing Or _
      Not Application.Intersect(Target, Range("T:T")) Is Nothing Then
        Target.Offset(0, 1).Value = Date
   End If
ActiveSheet.Protect
End Sub
（もこな２） 2017/12/25(月) 15:13

こうですか

 Option Explicit

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range

    If Target.Column = 17 Or Target.Column = 20 Then
        Application.EnableEvents = False
        Unprotect

        For Each r In Target
            If r.Value = "" Then
                r.Offset(, 1).ClearContents
            Else
                r.Offset(, 1).Value = Date
            End If
        Next

        Protect
        Application.EnableEvents = True
   End If

 End Sub

（マナ） 2017/12/25(月) 19:02

あぁそうか。。。
ブランクなら（に変化したら）クリアする機能も必要なんですね。
失礼しました。
（もこな２） 2017/12/25(月) 21:14

希望していた動作が確認できました。
お二方ありがとうございました。
（もち） 2017/12/26(火) 10:25

コメント返信：

[ 一覧(最新更新順) ]

[[20171225133904]] 『Activesheet.protectについて』（もち） ページの最後に飛ぶ

[[20171225133904]]　『Activesheet.protectについて』（もち）　ページの最後に飛ぶ