Mulighed for kun at tilføje i et ark efter save?

Indsæt disse i ThisWorkbook

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveSheet.Unprotect
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True
End Sub

Private Sub Workbook_Open()
ActiveSheet.Unprotect
ActiveSheet.Protect
End Sub

Virker først efter genåbning

ActiveSheet kan udskiftes med Sheets("dit ark navn")

Hmm, det virker ikke rigtigt. Jeg kan stadig få lov at ændre i de eksisterende rækker.

Jeg lagde den først ind som et 'module' under ThisWorkbook, og der kunne jeg få lov at ændre i de eksisterende rækker. Forsøgte så at smide den ind direkte under ThisWorkbook, og nu er hele arket protected, og jeg kan ikke indsætte nye rækker.

ja de skal være direkte i thisworkbook
og nej du kan ikke indsætte noget før du har gemt
var det ikke det du ville ?

Nej, ikke helt.

Det skal fungere på denne måde (eksempel):

Der ligger 3 rækker med data. Når man trykker save bliver disse tre rækker låst, og det er derefter ikke muligt at rette i dem eller slette dem, men man kan til gengæld godt tilføje nye rækker med data. Det er altså kun de celler der står noget i der skal 'protectes'. Giver det mening?

hmm måske :-) prøv :

Start med at markere alle seller i arket (klik på øverste grå felt)
Højreklik i markering og vælg Formater Selle
Vælg fanen Beskyttelse og fjern flueben i Låst

Højreklik på Arket fane og indsæt følgende kode:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target <> "" Then Target.Locked = True
If Target = "" Then Target.Locked = False
End Sub

koden låser seller som ikke er tomme fremover

hvis du har seller i arket i forvejen skal disse låses
disse markeres nemmest med F5 > Speciel
vælg evt. først Formler  - lås dem
vælg derefter Konstanter og lås dem

Indsæt denne i arkets kodemodul i stedet for ovenstående

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
If Target <> "" Then Target.Locked = True
If Target = "" Then Target.Locked = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True
End Sub

du skriver :Når man trykker save bliver disse tre rækker låst
mener du så hele rækken ?

rettelse til kode - den gav problemer med indsæt række

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
On Error GoTo ud
If Target <> "" Then Target.Locked = True
If Target = "" Then Target.Locked = False
ud:
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True
End Sub

Det virker næsten efter planen! Det er kun muligt at tilføje en række, men den bliver til gengæld ikke låst efter man har savet og lukket. Det var altså muligt at editere i den nyindsatte række når man åbnede igen. Legede lidt videre derhjemme, og kom frem til at følgende virker efter planen:

Private Sub Workbook_Open()
Dim MyRow As Integer
Dim MyData As String
Dim MyCell As Variant
Dim MyRange As Variant
Dim MyWks As Worksheet

Set MyWks = Application.ActiveSheet        - Her finder vi dit regnearkobjekt, det er enkelt der er jo kun et
MyWks.Unprotect                    - Vi låser op, eller må vi ikke "rode" i det

MyRow = 0
MyData = "x"

Do While MyData > ""                - Standard loop, læs til vi møder en tom celle i række 1 (mit eksempel altså)
  MyRow = MyRow + 1
  MyCell = "A" + Right(Str(MyRow), (Len(MyRow) - 1))
  Range(MyCell).Select
  MyData = ActiveCell.Text
  If MyData = "" Then
   
    With MyWks.Protection.AllowEditRanges.Item(1)    - Når vi møder en tom celle, så start med at smide tidligere tilladelser ud
        .Delete                        - ellers har vi pludselig hundrede af dem!
    End With
       
    MyRange = MyCell + ":C65536"            - Sæt range til den tomme celle til bunden af excel
    MyWks.Protection.AllowEditRanges.Add _        - Giv lov til at pille
        Title:="Classified", _
        Range:=Range(MyRange), _
        Password:=""
  End If
Loop

MyWks.Protect                - Og så slutter vi af med at låse igen

End Sub

Det virker efter planen. Man skal så huske at lave en edit range. MyRow sættes til 0 hvis det er den første celle i arket, ellers kan man justere hvis man starter andetsteds.

Tak for hjælpen! Opretter du et svar så du kan få dine point?

ok