Makros nur in gerade angezeigter Datei ausführen
22.06.2016 16:29:26
Katja
Hallo,
wenn ich wüsste, wie das geht würde ich nicht fragen.
Habe das Makro nicht geschrieben, den Kollegen gibt es bei uns nicht mehr.
Makro 1: Für die Spalten B-G
Sub Schutzmakro()
' Schutzmakro Makro
' Tastenkombination: Strg+m
ActiveSheet.Unprotect
' Spalte B ist die einzige durchlaufend besetzte Spalte,
' daher wird diese als Maß für das Auffüllen der Tabelle benutzt
' die erste mögliche Position in dieser Spalte gesetzt
Range("B7").Select
Counter = 0
' Schleife soll laufen, bis eine Zelle ohne Eintrag erreicht ist
' Überprüfung auf "NUL" genügt, da dann zumindest alle notwendigen Zellen geschützt sind.
Do ' Jetzt werden alle Zellen pro Zeile hintereinander weg geschützt.
Selection.Offset(Counter, 0).Locked = True
Selection.Offset(Counter, 1).Locked = True
Selection.Offset(Counter, 2).Locked = True
Selection.Offset(Counter, 3).Locked = True
Selection.Offset(Counter, 4).Locked = True
Selection.Offset(Counter, 5).Locked = True
' Zähler wird um 1 erhöht, die nächste Zeile ist dran.
Counter = Counter + 1
' Schleife beginnt erneut.
Loop Until Selection.Offset(Counter, 0).Value = ""
' kompletter Blattschutz für die gesamte Tabelle wir wieder eingerichtet
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Aktuelle Tabelle wird gesichert.
ActiveWorkbook.Save
End Sub
Makro 2: Für die Spalten B-M
Sub Schutzmakro()
' Schutzmakro Makro
' Tastenkombination: Strg+m
ActiveSheet.Unprotect 'für das aktuelle Blatt in der aktiven Arbeitsmappe Blattschutz _
aufheben
' Spalte G (Riss-Nr.) ist die einzige durchlaufend besetzte Spalte,
' daher wird diese als Maß für das Auffüllen der Tabelle benutzt
' die erste mögliche Position in dieser Spalte gesetzt
Range("G5").Select
Zeile = 0
' Schleife soll laufen, bis eine Zelle ohne Eintrag erreicht ist
' Überprüfung auf "NUL" genügt, da dann zumindest alle notwendigen Zellen geschützt sind.
Do
' Jetzt werden alle Zellen pro Zeile hintereinander weg geschützt.
Selection.Offset(Zeile, 0).Locked = True
Selection.Offset(Zeile, 1).Locked = True
Selection.Offset(Zeile, 2).Locked = True
Selection.Offset(Zeile, 3).Locked = True
Selection.Offset(Zeile, 4).Locked = True
Selection.Offset(Zeile, 5).Locked = True
Selection.Offset(Zeile, 6).Locked = True
Selection.Offset(Zeile, -1).Locked = True
Selection.Offset(Zeile, -2).Locked = True
Selection.Offset(Zeile, -3).Locked = True
Selection.Offset(Zeile, -4).Locked = True
Selection.Offset(Zeile, -5).Locked = True
Zeile = Zeile + 1 'nächste Zeile --> Schleife beginnt erneut
Loop Until Selection.Offset(Zeile, 0).Value = "" 'bedeutet: laufe bis beliebiger Zeile in _
Rissspalte leer ist
' kompletter Blattschutz für die gesamte Tabelle wird wieder eingerichtet
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save ' Aktuelle Arbeitsmappe wird gespeichert.
End Sub