Hallo Alfonso,
hier die gewünschte Erweiterung, 10 Zeilen, statt einer Zeilen einfügen:
3 Zeilen im Makro eingefügt.
********************************************************************************
Dim i As Integer
For i = 1 To 10 ' Folgende Schritte bis "Next i" 10 mal Wiederholen ( = 10 Zeilen einfügen)
Next i ' Schritte bis Hier, 10 mal Wiederholen ( = 10 Zeilen einfügen)
*********************************************************************************
*********************************************************************************
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MaxDatenZeile As Integer
Dim SuchSpalte As Integer
Dim i As Integer
' Die Tabelle sollte in den 2 Letzten Zeilen nur Formeln und gewünschte Rahmen haben.
' Die letzte Zeile dient als Musterzeile mit Formeln und wird vom Makro Kopiert!
' Letzte Muster - Zeile mit Formeln bitte färben,
' um aus versehen keine Einträge vorzunehmen,
' ebenso mit den gewünschten Rahmen versehen,
' Garantierter Formel - Eintrag in Letzte Muster - Datenzeile in Spalte ? (5)
' "Spaltenangabe Bitte Anpassen"
SuchSpalte = 5
' Muster - Datenzeile ermitteln.
MaxDatenZeile = ActiveSheet.Cells(Rows.Count, (SuchSpalte)).End(xlUp).Row
' (Minus 1 ist Letzte Leere Dateneingabezeile)
MaxDatenZeile = MaxDatenZeile - 1
' Wenn in Spalte A der letzten Eingabezeile (Zeile oberhalb der Musterzeile),
' ein Eintrag vorgenommen wird, wird die Musterzeile Kopiert,
' so daß wieder eine Eingabezeile zur Verfügung steht.
If Range("A" & (MaxDatenZeile)) > "" And Range("A" & (MaxDatenZeile) + 1) = "" Then
' Blattschutz entfernen
On Error Resume Next
ActiveSheet.Unprotect "passwort"
For i = 1 To 10 ' Folgende Schritte bis "Next i" 10 mal Wiederholen ( = 10 Zeilen einfügen)
' Then von oben ausführen
MaxDatenZeile = MaxDatenZeile + 1
' Letzte Leere Dateneingabezeile mit Formatierung Auswählen und Kopieren
Rows((MaxDatenZeile) & ":" & (MaxDatenZeile)).Select
Selection.Copy
' Fügt die Kopierte Zeile in das Arbeitsblatt ein und verschiebt die Musterzeile nach unten,
' so paßen sich die Formel Automatisch an.
Selection.Insert Shift:=xlDown
' Rahmen von Kopiemarkierung löschen
Application.CutCopyMode = False
' Eingabe- Zeile Entfärben
Selection.Interior.ColorIndex = xlNone
' Zelle in Spalte A, B, D, der neuen Eingabezeile den Zellschutz entfernen
Range("A" & (MaxDatenZeile)).Locked = False
Range("B" & (MaxDatenZeile)).Locked = False
Range("D" & (MaxDatenZeile)).Locked = False
' Eingabezelle nach dem Zeilen Kopieren Aktivieren
Range("B" & (MaxDatenZeile) - 10).Select
Next i ' Schritte bis Hier, 10 mal Wiederholen ( = 10 Zeilen einfügen)
' Blattschutz setzen
On Error Resume Next
ActiveSheet.Protect "passwort", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
End If
End Sub
hddiesel
