Makro mit PW, aber trotzdem Abfrage

[KS20]

Hallo, 

habe ein Makro geschrieben, wo ich wenn eine bestimmte Bedingung erfüllt ist die Zeilen in einen neuen Reiter kopieren lasse.
Allerdings soll dieser Reiter schreibgeschützt sein.

Also mein Makro:

Password aufheben--> Zeilen kopieren--> Password setzen!

nun frag er mich jedesmal nach dem Password, wenn ich die Excel neu starte!

Kann mir da wer helfen?






Sub kopieren() 
 ActiveSheet.Unprotect Password:="test2000"
 Range("A9:Bg500").Clear
  Application.ScreenUpdating = False
  Dim myRow As Long
 Dim myLastRow1 As Long
 Dim myLastRow2 As Long
  With Sheets("02")
     myLastRow1 = .Cells(Rows.Count, 26).End(xlUp).Row
     If myLastRow1 < 9 Then Exit Sub
 End With 
 For myRow = 9 To myLastRow1
      If Sheets("02").Cells(myRow, 26).Value = "ja" Then
              With Sheets("01")
             myLastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
             If myLastRow2 < 8 Then myLastRow2 = 8
         End With
           Sheets("02").Rows(myRow).Copy Destination:=Sheets("01").Rows(myLastRow2 + 1)
          End If
  Next myRow 
  Application.ScreenUpdating = True   
  ActiveSheet.Protect Password:="test2000"
  ActiveSheet.Protect userinterfaceonly:=True
  ActiveSheet.EnableAutoFilter = True
 
 End Sub

[Kuwer]

Hallo,

teste es mal so. Jetzt spielt es keine Rolle, welches Blatt gerade aktiv ist.

Sub kopieren()
 Dim myRow As Long
 Dim myLastRow1 As Long
 Dim myLastRow2 As Long
    
 myLastRow1 = Sheets("02").Cells(Rows.Count, 26).End(xlUp).Row
 If myLastRow1 > 8 Then
   Application.ScreenUpdating = False
   With Sheets("01")
     .Unprotect Password:="test2000"
     .Range("A9:Bg500").Clear
     For myRow = 9 To myLastRow1
       If Sheets("02").Cells(myRow, 26).Value = "ja" Then
         myLastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
         If myLastRow2 < 8 Then myLastRow2 = 8
         Sheets("02").Rows(myRow).Copy Destination:=.Rows(myLastRow2 + 1)
       End If
     Next myRow
     .Protect Password:="test2000", UserInterfaceOnly:=True
     .EnableAutoFilter = True
   End With
   Application.ScreenUpdating = True
 End If
End Sub

Gruß Uwe

[KS20]

Guten Morgen,

so funktioniert es leider nicht,

kommt zwar keine PW abfrage mehr, allerdings löscht er mir jetzt auch die Originalliste

in 01 werden Daten erfasst und in 02 werden Daten reinkopiert, wenn in 01 bestimmte Bedingung erfüllt ist.

MfG

[Kuwer]

Hallo,

allerdings löscht er mir jetzt auch die Originalliste

die Zeile

Range("A9:Bg500").Clear

war aber von Dir.

in 01 werden Daten erfasst und in 02 werden Daten reinkopiert, wenn in 01 bestimmte Bedingung erfüllt ist.

In Deinem Code war es genau andersrum und daran hielt ich mich.

Gruß Uwe

[KS20]

Hallo Uwe,

Danke!

War mein Fehler, hatte die Reiter verwechselt^^

Nun funktioniert es viele DANK !!!!!