Cellen op slot na verstrijken van maand

[Gerard2348]

Beste forumleden,

Onderstaande code sluit bepaalde kolommen af nadat de maand verstreken is. Kan dit op een andere (betere) manier?

Private Sub Workbook_Open()

ActiveSheet.Unprotect "1234"
If Range("B2") > 42766 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 42794 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
If Range("B2") > 42825 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 42855 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
If Range("B2") > 42886 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 42916 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
If Range("B2") > 42947 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 42978 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
If Range("B2") > 43008 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 43039 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
If Range("B2") > 43069 Then
Worksheets("Blad1").Range("G7:H200").Locked = True
End If
If Range("B2") > 43100 Then
Worksheets("Blad1").Range("I7:J200").Locked = True
End If
ActiveSheet.Protect "1234"
End Sub

Groet Geer

Bekijk bijlage Map1.xlsm

 

[SjonR]

Waarom zes keer dezelfde range locken?

 

[Piet Bom]

Ik heb de macro zo aangepast:

Private Sub Workbook_Open()
  Sheets("Blad1").Select
  ActiveSheet.Unprotect Password:="1234"
  Range("G7:AD999").Locked = False
  mnd = Month(Now()) - 1
  If mnd >= 1 Then
    k = mnd * 2 + 6
    LC = Cells(999, k).Address
    txt = "$G$7:" & LC
    Range(txt).Locked = True
  End If
  ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="1234"
End Sub

 

[Gerard2348]

Ha SjonR,

6 keer dezelfde range locken is ook zeker niet nodig. Ik zie nu dat dit niet het juiste bestand is. Dit moeten de volgende kolommen zijn;
G:H, I:j, K:L, M:N, O, Q:R, S:T, U:V, W:X, Y:Z, AA:AB, AC:AD.

stom,stom, stom.

Piet jouw code ziet er veelbelovend uit. Deze ga ik uitproberen.

Hartelijk dank :thumb:

 

[VenA]

Mogelijk is dit voldoende

Sub VenA()
Dim j As Long
  For j = 8 To 30 Step 2
    If DateSerial(Year(Date), (j - 8) / 2 + 2, 1) < Date Then Blad1.Cells(7, j).Resize(193).Locked = True
  Next j
End Sub

 

[Gerard2348]

De code van Piet werkt (zover ik heb kunnen uitproberen).
De code van VenA heb ik geprobeerd maar deze locked de cellen niet.

Groet Geer

 

[VenA]

Welke cellen worden niet gelocked? Hoe heb je het getest?

Klik op de knop en bekijk de de celeigenschappen van H7:H199

 

[Gerard2348]

Ha VenA,

Heb jouw code getest door deze in een module te plaatsen en te runnen.
Na de volgende aanpassingen werkt hij wel;

Sub VenA()
Dim j As Long
 [COLOR="#FF0000"] ActiveSheet.Unprotect "1234"[/COLOR]
  For j = [COLOR="#FF0000"]7[/COLOR] To 30 Step [COLOR="#FF0000"]1[/COLOR]
    If DateSerial(Year(Date), (j - 7) / 2 + 2, 1) < Date Then Blad1.Cells(7, j).Resize(193).Locked = True
  Next j
 [COLOR="#FF0000"] ActiveSheet.Protect "1234"[/COLOR]
End Sub

j op 7 gezet en step op 1. Dit omdat dan beide kolommen onder de maand worden gelocked. In de voorgaande code werd alleen de 2de kolom gelocked.


:thumb: :thumb:

 

[Gerard2348]

Gekozen voor de oplossing van Piet

Sheets("Home").Select

  ActiveSheet.Unprotect "1234"
  Sheets("Home").Select
  [COLOR="#FF0000"]ActiveWindow.ScrollColumn = 1[/COLOR]
  
  Range("G7:AD999").Locked = False
  mnd = Month(Now()) - 1
  If mnd >= 1 Then
    k = mnd * 2 + 6
    lc = Cells(150, k).Address
    txt = "$G$7:" & lc
    Range(txt).Locked = True
  [COLOR="#FF0000"]ActiveWindow.SmallScroll ToRight:=k - 6[/COLOR]
  End If

Dit omdat door de toevoeging (in het rood) niet alleen de bijbehorende cellen worden gelocked maar ook omdat er dan naar de betreffende maand wordt gescrolled.

:thumb: