Hallo, 

ich stecke fest bei meinem VBA-Tool. 

Undzwar ist das Problem folgendes: 

Ich kpiere von einem Sheet ins andere Daten , diese Sheet hat einen Blattschutz den ich natürlich am Anfang aufhebe und am Ende wieder aktiviere. 

Allerdings schützt er die von mir neu eingefügten Zeilen nicht , s das man immernoch darauf zugreifen kann. 

Gibt es dafür einen Befehl dass, eventuel alle neu eingefügten Zeilen auch geschützt werden. 

Hier ist der Code 

Sub Stoerung_behoben()
   
   'Blattschutz deaktivieren
   Sheets("Fehlersammelliste").Unprotect Password:="JTI-2020"


Range("I7") = Date & " " & Format(Time, "hh:mm:ss")
Worksheets("Fehlersammelliste").Activate
' Zeileeinfügen Makro
    Rows("4:4").Select
    Selection.Insert Shift:=x1Down, CopyOrigin:=xlFormatFromLeftOrAbove


Sheets("Eintragungen").Range("A7").Copy Sheets("Fehlersammelliste").Range("B4")
Sheets("Eintragungen").Range("I7").Copy Sheets("Fehlersammelliste").Range("C4")


Dim Zeit1 As Date
Dim Zeit2 As Date
Dim Sek As Long
Dim Min As Long
Dim Std As Long


Zeit1 = Sheets("Fehlersammelliste").Range("B4")
Zeit2 = Sheets("Fehlersammelliste").Range("C4")

Sek = DateDiff("s", Zeit1, Zeit2)

Std = Int(Sek / 3600)
Min = Int((Sek - (Std * 3600)) / 60)
Sek = Sek - ((Std * 3600) + (Min * 60))
Sheets("Fehlersammelliste").Range("D4").Value = Std & ":" & Min & ":" & Sek


Sheets("Eintragungen").Range("C7").Copy Sheets("Fehlersammelliste").Range("E4")
Sheets("Eintragungen").Range("D7").Copy Sheets("Fehlersammelliste").Range("F4")
Sheets("Eintragungen").Range("E7:E7").Copy Sheets("Fehlersammelliste").Range("G4:G4")
'Sheets("Eintragungen").Range("H7:I7").Copy Sheets("Fehlersammelliste").Range("I4:I4")
'Sheets("Eintragungen").Range("L7").Value = Sheets("Eintragungen").Range("L7").Value + 1
Sheets("Eintragungen").Range("L7").Copy Sheets("Fehlersammelliste").Range("A4")
Sheets("Eintragungen").Range("A7").ClearContents
Sheets("Eintragungen").Range("C7:D7").ClearContents
Sheets("Eintragungen").Range("E7:F7").ClearContents
Sheets("Eintragungen").Range("H7:I7").ClearContents
Sheets("Eintragungen").Range("I7").ClearContents
' Rücksprung Anfang
Sheets("Eintragungen").Select
Range("C7").Select
'Autosummation der Firmenauswertung
'Optima

Worksheets("Fehlersammelliste").Range("K2") = _
   WorksheetFunction.SumIf(Range("Fehlersammelliste!G4:G1000"), "Optima", Range("Fehlersammelliste!D4:D1000"))

Worksheets("Fehlersammelliste").Range("L2") = _
   WorksheetFunction.SumIf(Range("Fehlersammelliste!G4:G1000"), "JTI", Range("Fehlersammelliste!D4:D1000"))
   
Worksheets("Fehlersammelliste").Range("M2") = _
   WorksheetFunction.SumIf(Range("Fehlersammelliste!G4:G1000"), "Hoerauf", Range("Fehlersammelliste!D4:D1000"))

Worksheets("Fehlersammelliste").Range("N2") = _
   WorksheetFunction.SumIf(Range("Fehlersammelliste!G4:G1000"), "Emkon1", Range("Fehlersammelliste!D4:D1000"))
   
Worksheets("Fehlersammelliste").Range("O2") = _
   WorksheetFunction.SumIf(Range("Fehlersammelliste!G4:G1000"), "Emkon2", Range("Fehlersammelliste!D4:D1000"))

 'Blattschutz aktivieren
 Sheets("Fehlersammelliste").Protect Password:="JTI-2020"

End Sub

Vielen Dank schonmal