PDA

View Full Version : Lock Cells after date passed - VBA Code



Trebby
04-18-2015, 05:09 AM
Hi,


Please can you advise?


I'm still very much a novice to VBA coding and would like some help before I lose all my hair for good


I'm trying to allow staff to enter text into merge cells, and once the deadline date has passed it will auto lock these cells so editing cannot be done (audit purposes). I want to do this so it works on a month to month, though my code below only allows for Jan 2015.


Below is the code I'm using but I feel all my ranges aren't quite right





Private Sub Workbook_Open()

Dim wksTarget As Worksheet
Dim rngDate As Range
Dim rngData As Range
Dim c As Long
Dim LastRow As Long
Dim LastCol As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Consents") '<< adjust to suit

If Not blnUnlockedAllCells Then
wksTarget.Protect Password:=craig, userinterfaceonly:=True
wksTarget.Cells.Locked = False
blnUnlockedAllCells = True
End If

Set rngData = wksTarget.Range("C7:M14") '<< adjust to suit. range including the date row

For c = 7 To rngData.Columns.Count
If CDate(rngData(7, c)) <= Date - 2 Then
On Error Resume Next
rngData.Columns(c).SpecialCells(8).Locked = True
On Error GoTo 0
End If
Next

End Sub

Thanks for you help in advance.

Paul_Hossler
04-18-2015, 06:35 AM
I'd probably do something like this




Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Consents") '<< adjust to suit

With wksTarget
Call .Unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub


I changed the interior color so I wouldn't get confused. You can take it out if you don't want it

Trebby
04-18-2015, 06:50 AM
Paul that worked like a charm. You sir are indeed a true guru of VBA. I prefer the colors as well.

Thanks for your time and help.

Trebby
04-18-2015, 07:24 AM
Hi,

I've transferred that code over to a different sheet and get this error on the first line of your code "Private Sub Workbook_Open() "Ambiguous name detected""

full code below



Private Sub Workbook_Open()
With Sheet1
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet2
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet3
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet4
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet5
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet6
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet7
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet8
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet9
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet10
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet11
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet12
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet13
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet14
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet15
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet16
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet17
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet18
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet19
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet20
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet21
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet22
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet23
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet24
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet25
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet26
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet27
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
With Sheet28
.unprotect Password:="craig"
.Protect Password:="craig", userinterfaceonly:=True
.EnableOutlining = True
End With
UserForm1.Show
End Sub
Private Sub Workbook_beforeclose(cancel As Boolean)
Sheets("Overtime").Visible = False
End Sub
Private Sub Workbook_Open() "Ambiguous name detected"

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Consents") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub
Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Enviro Mangt System") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub
Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Service Delivery Issues") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub
Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Inspection Reports") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub
Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Enquiries Plan") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With

End Sub
Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10


Dim wksTarget As Worksheet
Dim iDeadline As Long

Const craig As String = "craig" '<< adjust to suit

Set wksTarget = ThisWorkbook.Worksheets("Miscellaneous") '<< adjust to suit

With wksTarget
Call .unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(7, 11).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(7, 11).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End With
End Sub

gmayor
04-18-2015, 07:32 AM
I think you will find the attached will work.

PS. I see someone beat me to it, and I prefer the alternative, so I have pulled the attachment.

As for the error relating to your changes, you can't have three macros with the same name. You'll have to incorporate the code in the same macro, or create a series of macros and call them from Workbook_Open.

Trebby
04-18-2015, 07:38 AM
Thank you for taking the time, that works fine, but when I add that to another code I get the top line Private Sub Workbook_Open() as an error states Ambiguous name detected: Workbook_Open

Trebby
04-18-2015, 07:41 AM
I think you will find the attached will work.

PS. I see someone beat me to it, and I prefer the alternative, so I have pulled the attachment.

As for the error relating to your changes, you can't have three macros with the same name. You'll have to incorporate the code in the same macro, or create a series of macros and call them from Workbook_Open.

Sorry for the noob reply but how would you incorporate it into the same one?

I think I've manage to incorporate it. Thanks guys

Paul_Hossler
04-18-2015, 09:34 AM
Trebby -- From your PM question

IMHO it's good defensive programming not to have to hard code WS names into a macro so I used a 'marker' in worksheets that need to be protected

>>>>>***** !!!!! This has to be the ONLY sub called Workbook_Open in the ThisWorkbook module !!!!! ***** <<<<<




Private Sub Workbook_Open()

Const ciStartDeadlineRow As Long = 7
Const ciDeadlineRowGap As Long = 10
Const ciNumberTextRows As Long = 7
Const ciNumberTextColumns As Long = 11
Const craig As String = "craig" '<< adjust to suit

Dim ws As Worksheet
Dim iDeadline As Long

For Each ws In ThisWorkbook.Worksheets

With ws

'A1 on any desired sheet has DEADLINE in white font in A1 as a marker
If .Cells(1, 1).Value = "DEADLINE" Then

Call .Unprotect(craig)

'lock all
.Cells.Locked = True
.EnableSelection = xlUnlockedCells

'only unlock cells if deadline date is in fture
For iDeadline = ciStartDeadlineRow To (ciStartDeadlineRow + 11 * ciDeadlineRowGap) Step ciDeadlineRowGap
If .Cells(iDeadline, 3).Value > Now Then
.Cells(iDeadline + 1, 3).Resize(ciNumberTextRows, ciNumberTextColumns).Interior.Color = RGB(255, 255, 153)
.Cells(iDeadline + 1, 3).Resize(ciNumberTextRows, ciNumberTextColumns).Locked = False
Else
.Cells(iDeadline + 1, 3).Resize(ciNumberTextRows, ciNumberTextColumns).Interior.Color = RGB(217, 217, 217)
End If

Next iDeadline

.Protect Password:=craig, userinterfaceonly:=True
End If
End With

Next
End Sub

Trebby
04-18-2015, 09:46 AM
Paul that is perfect and looks so simple. Thank you for your time today friend, Sorry to be a pain

Paul_Hossler
04-18-2015, 11:41 AM
It's no problem, and you weren't