Clever-Excel-Forum

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

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

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

Hallo,

(15.07.2016, 06:01)KS20 schrieb: [ -> ]allerdings löscht er mir jetzt auch die Originalliste

die Zeile

Range("A9:Bg500").Clear

war aber von Dir.

(15.07.2016, 06:01)KS20 schrieb: [ -> ]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

Hallo Uwe,

Danke!

War mein Fehler, hatte die Reiter verwechselt^^

Nun funktioniert es viele DANK !!!!!