Vba 根据日期解锁指定的行范围

我需要一些帮助来升级我的VBA代码

我试图找到一个代码，该代码将根据当前日期解锁特定行。问题是，我不希望所有行的单元格都被解锁，只希望一组特定的区域被解锁。与列“B”中的当前日期一样，解锁的单元格将从（“D”到“K”）；（“M”至“P”）；（“R”至“S”）和（“U”至“V”）

中间的单元格包含公式，我不希望人们弄乱或错误地更改这些公式

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Range("B" & Selection.Row).Value <> Date Then
        ActiveSheet.Protect Password:="3827"
        MsgBox "Only today's date needs to be edited!", vbInformation, "REMINDER"
    ElseIf Range("B" & Selection.Row).Value = Date Then
        ActiveSheet.Unprotect Password:="3827"
        ActiveSheet.EnableSelection = xlNoRestrictions
    End If
End Sub

Private子工作表\u selection更改（ByVal目标作为范围）
如果是范围（“B”和Selection.Row）。则为值日期
ActiveSheet.Protect密码：=“3827”
MsgBox“只需编辑今天的日期！”，vbInformation，“提醒”
ElseIf范围（“B”和Selection.Row）。值=日期
ActiveSheet.Unprotect密码：=“3827”
ActiveSheet.EnableSelection=xlnRestrictions
如果结束
端接头

为什么不更进一步呢？当工作表激活时，仅允许他们选择这些列的当前日期行

Option Explicit

Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D:K,M:P,R:S,U:V"

Private Sub Worksheet_Activate()
    Dim dToday As Date, oRng As Range, oItem As Variant
    dToday = Date
    With ActiveSheet
        .Unprotect Password:=PWD
        .Cells.Locked = True
        ' Look for row with today's date and unlock the row inside usedrange
        Set oRng = .Columns("B").Find(What:=dToday)
        If Not oRng Is Nothing Then
            For Each oItem In Split(UNLOCK_COLS, ",")
                Intersect(oRng.EntireRow, .Columns(oItem)).Locked = False
            Next
        End If
        .Protect Password:=PWD
        .EnableSelection = xlUnlockedCells
    End With
End Sub

---

通过Tim Williams提供的优化建议，您甚至可以跳过以下循环：

Option Explicit

Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D1:K1,M1:P1,R1:S1,U1:V1"

Private Sub Worksheet_Activate()
    Dim dToday As Date, oRng As Range
    dToday = Date
    With ActiveSheet
        .Unprotect Password:=PWD
        .Cells.Locked = True
        ' Look for row with today's date and unlock the specific columns in the row
        Set oRng = .Columns("B").Find(What:=dToday)
        If Not oRng Is Nothing Then oRng.EntireRow.Range(UNLOCK_COLS).Locked = False
        .Protect Password:=PWD DrawingObjects:=False, Contents:=True, Scenarios:=True ' This allows Adding comments
        .EnableSelection = xlUnlockedCells
    End With
End Sub

---

在保护工作表之前，请尝试以下类似“range.locked=False”的操作。保护工作表时，只有锁定的单元格才会受到保护。未锁定的单元格（即，locked=false）将不会在受保护的工作表上受到保护。这使您可以查看多列范围

范围（“D:K，M:P，R:S，U:V”）。选择
。。。但请使用这种方式：
Range（“D:K，M:P，R:S，U:V”）。Locked=False
，如@Jaromfor这些列中的单行所述<代码>相交（第（8）行，范围（“D:K，M:P，R:S，U:V”）。选择
和
相交（第（8）行，范围（“D:K，M:P，R:S，U:V”）。锁定=False
。。。不要忘记，.Select仅用于调试，以便查看结果范围。不要在生产代码中使用它，除非真的，真的需要或者
行（8）.Range（“D1:K1，M1:P1，R1:S1，U1:V1”）
@TimWilliams我比你更喜欢这种形式谢谢你这么多，我最近开始学习VBA，你的代码好得多，完全解决了我的问题。非常感谢抱歉，但是有没有办法修改代码，使使用该工作表的人可以在需要时在解锁单元格上插入注释？我录制了宏以在保护期间执行您需要的操作，您只需添加
DrawingObjects:=False，Contents:=True，Scenarios:=True
（请参阅已编辑的答案）。但您可能还想在保护之前删除现有注释？