bestimmte Anzahl an Zeilen kopieren und einfügen

Sub ZeileKopieren_Task() Dim i As Integer Application.ScreenUpdating = False 'alles einblenden Dim af As Variant With ActiveSheet If .AutoFilterMode Then For Each af In .AutoFilter.Filters If af.On Then .ShowAllData Exit For End If Next End If End With Application.ScreenUpdating = True 'Zeile kopieren i = ActiveCell.Row Rows(i + 1 & ":" & i + 1).Select Selection.Insert Shift:=xlDown Rows(i & ":" & i).Select Selection.Copy Range("A" & i + 1).Select ActiveSheet.Paste Range("T" & i + 1).ClearContents Range("U" & i + 1).ClearContents Range("G" & i + 1).Select Range("G" & i + 1).Value = InputBox("bitte Sprint-Woche eingeben:", "Sprint Woche", " _ Sprint_" & Range("B1")) Range("H" & i + 1).Select Range("H" & i + 1).Value = InputBox("bitte Sprint-Ziel eingeben:", "Sprint Ziel", Range("H" _ & i)) Range("N" & i + 1).Select Range("N" & i + 1).Value = InputBox("bitte Task eingeben:", "Task", Range("N" & i)) 'gemerkten Filter wiederherstellen If Worksheets("Hilfe").Range("F2").Value = "Filter SW" Then Call filter_SW End If If Worksheets("Hilfe").Range("F2").Value = "Filter ME" Then Call filter_ME End If If Worksheets("Hilfe").Range("F2").Value = "Filter EE" Then Call filter_EE End If If Worksheets("Hilfe").Range("F2").Value = "Filter PS" Then Call filter_PS End If If Worksheets("Hilfe").Range("F2").Value = "Filter CRE" Then Call filter_CRE End If If Worksheets("Hilfe").Range("F2").Value = "kein Filter" Then Call AutofilterRücksetzen End If 'gemerkte Sprints wiederherstellen If Worksheets("Hilfe").Range("F3").Value = "3-Wochen-Sprints" Then '3 Wochen Sprint Call TasksAusblenden End If If Worksheets("Hilfe").Range("F3").Value = "alle Sprints" Then 'alle Sprints Call TasksEinblenden End If If Worksheets("Hilfe").Range("F3").Value = "aktueller Sprint" Then 'aktueller Sprint Call AktuelleTasks End If 'neue Zeile markieren Rows(i + 1 & ":" & i + 1).Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ZeileKopieren_Task() Dim i As Integer, cl As Range Application.ScreenUpdating = False 'alles einblenden Dim af As Variant With ActiveSheet If .AutoFilterMode Then For Each af In .AutoFilter.Filters If af.On Then .ShowAllData Exit For End If Next End If End With Application.ScreenUpdating = True For Each cl In Selection.Cells 'Zeile kopieren i = cl.Row + 1 cl.EntireRow.Copy cl.Offset(1, 0).EntireRow.Insert shift:=xlShiftDown Range("T" & i & ":U" & i).ClearContents Range("G" & i).Value = InputBox("bitte Sprint-Woche eingeben:", "Sprint Woche", "Sprint" & _ Range("B1")) Range("H" & i).Value = InputBox("bitte Sprint-Ziel eingeben:", "Sprint Ziel", Range("H" & i) _ ) Range("N" & i).Value = InputBox("bitte Task eingeben:", "Task", Range("N" & i)) Next 'gemerkten Filter wiederherstellen Select Case Worksheets("Hilfe").Range("F2").Value Case "Filter SW" Call filter_SW Case "Filter ME" Call filter_ME Case "Filter EE" Call filter_EE Case "Filter PS" Call filter_PS Case "Filter CRE" Call filter_CRE Case "kein Filter" Call AutofilterRücksetzen End Select 'gemerkte Sprints wiederherstellen Select Case Worksheets("Hilfe").Range("F3").Value Case "3-Wochen-Sprints" '3 Wochen Sprint Call TasksAusblenden Case "alle Sprints" 'alle Sprints Call TasksEinblenden Case "aktueller Sprint" 'aktueller Sprint Call AktuelleTasks End Select End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'Datum setzen in Spalte T (20) If Target.Column = 20 Then If Target.Value = "ongoing" Or Target.Value = "0%" _ Or Target.Value = "25%" Or Target.Value = "50%" _ Or Target.Value = "75%" Or Target.Value = "100%" Then _ Target.Offset(0, 1).Value = Date End If End Sub

Hallo,
ich habe das Makro etwas angepasst. Jetzt könnte es laufen. Zur Erklärung:
Zu Deiner Anmerkung "a) 1 Zeile markiert - Makro kopiert die Zeile und geht in debugger. Ich habe auf dem Blatt noch folgendes Makro, hier markiert er die if-Bedingung if target.value..."
Im Rahmen des von mir erstellten Makros werden ja die Inhalte der Spalten T und U gelöscht. Das Worksheet_Change-Ereignis hat dann aber das Problem, dass in diesem Makro der Target, also die geänderten Zellen, über 2 Spalten (T und U) liegen, das ist bei Deinem Worksheet_Change-Ereignis nicht vorgesehen. Zur Behebung dieses Fehlers habe ich die Abarbeitung der Ereignisse (Worksheet_Change und andere) am Anfang mit Application.EnableEvents = False abgeschaltet und am Ende mit Application.EnableEvents = True wieder eingeschaltet.
Zu Deiner Anmerkung "b) mehrere Zeilen markiert - Makro geht in Endlos-Schleife wobei die Originalmarkierung bestehen bleibt. Kopiert werden aber immer die neu-angelegten Zeilen"
Bei meinen Tests hier hatte ich, wenn ich mehrere Zeilen markiert habe, diese immer mit gedrückter Strg-Taste einzeln angeklickt, dann hat das Makro geklappt. Nach Deinem letzten Post habe ich mehrere Zeilen markiert, indem ich über diese mit gedrückter Maustaste z. B. von B4 zu B6 gefahren bin. Dabei trat der geschilderte Fehler auf. Ich habe das Makro jetzt dahingehend geändert, dass die ausgewählten Zellen von unten abgearbeitet werden. Dadurch kann eine neu eingefügte Zeile nicht mehr die Zell-Adressen der noch abzuarbeitenden Zellen verändern. Am Ende wird jetzt die erste neu eingefügte Zeile markiert.
Noch eine Anmerkung: Wenn in einer Zeile 2 oder mehr Zellen markiert sind, wird diese Zeile auch 2-oder mehrfach kopiert. Wenn das auch noch abgefangen werden soll, gib bitte Bescheid.
Hier das geänderte Makro, die geänderten Stellen habe ich rot gekennzeichnet.

Sub ZeileKopieren_Task()
Dim i As Integer, cl As Range, j As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
'alles einblenden
Dim af As Variant
With ActiveSheet
If .AutoFilterMode Then
For Each af In .AutoFilter.Filters
If af.On Then
.ShowAllData
Exit For
End If
Next
End If
End With
Application.ScreenUpdating = True
For j = Selection.Cells.Count To 1 Step -1
'Zeile kopieren
i = Selection.Cells(j).Row + 1
Selection.Cells(j).EntireRow.Copy
Selection.Cells(j).Offset(1, 0).EntireRow.Insert shift:=xlShiftDown
Range("T" & i & ":U" & i).ClearContents
Range("G" & i).Value = InputBox("bitte Sprint-Woche eingeben:", "Sprint Woche", "Sprint" &  _
Range("B1"))
Range("H" & i).Value = InputBox("bitte Sprint-Ziel eingeben:", "Sprint Ziel", Range("H" & i) _
)
Range("N" & i).Value = InputBox("bitte Task eingeben:", "Task", Range("N" & i))
Next
Selection.Cells(1).Offset(1, 0).EntireRow.Select
'gemerkten Filter wiederherstellen
Select Case Worksheets("Hilfe").Range("F2").Value
Case "Filter SW"
Call filter_SW
Case "Filter ME"
Call filter_ME
Case "Filter EE"
Call filter_EE
Case "Filter PS"
Call filter_PS
Case "Filter CRE"
Call filter_CRE
Case "kein Filter"
Call AutofilterRücksetzen
End Select
'gemerkte Sprints wiederherstellen
Select Case Worksheets("Hilfe").Range("F3").Value
Case "3-Wochen-Sprints"  '3 Wochen Sprint
Call TasksAusblenden
Case "alle Sprints"       'alle Sprints
Call TasksEinblenden
Case "aktueller Sprint"    'aktueller Sprint
Call AktuelleTasks
End Select
Application.EnableEvents = True
End Sub

Gruß
Robert

Sub ZeileKopieren_Task2() Dim i As Integer, cl As Range, j As Integer, lZ As Long Dim strZeilen As String, strZeilenNeu As String, lZeilenNeu() As Long, k As Integer Application.ScreenUpdating = False Application.EnableEvents = False 'alles einblenden Dim af As Variant With ActiveSheet If .AutoFilterMode Then For Each af In .AutoFilter.Filters If af.On Then .ShowAllData Exit For End If Next End If End With Application.ScreenUpdating = True strZeilen = ";" ReDim lZeilenNeu(0) For Each cl In Selection.Cells If InStr(strZeilen, ";" & cl.Row & ";") = 0 Then strZeilen = strZeilen & cl.Row & ";" If lZ 0 Then Rows(j).Copy Rows(j).Offset(1, 0).EntireRow.Insert shift:=xlShiftDown Range("T" & j + 1 & ":U" & j + 1).ClearContents Range("G" & j + 1).Value = InputBox("bitte Sprint-Woche eingeben:", "Sprint Woche", " _ Sprint" & Range("B1")) Range("H" & j + 1).Value = InputBox("bitte Sprint-Ziel eingeben:", "Sprint Ziel", Range( _ "H" & j + 1)) Range("N" & j + 1).Value = InputBox("bitte Task eingeben:", "Task", Range("N" & j + 1)) For k = 0 To UBound(lZeilenNeu) lZeilenNeu(k) = lZeilenNeu(k) + 1 Next k ReDim Preserve lZeilenNeu(UBound(lZeilenNeu) + 1) lZeilenNeu(UBound(lZeilenNeu)) = j + 1 End If Next j For k = 1 To UBound(lZeilenNeu) strZeilenNeu = strZeilenNeu & ", " & lZeilenNeu(k) & ":" & lZeilenNeu(k) Next k Range(Mid(strZeilenNeu, 3)).Select 'gemerkten Filter wiederherstellen Select Case Worksheets("Hilfe").Range("F2").Value Case "Filter SW" Call filter_SW Case "Filter ME" Call filter_ME Case "Filter EE" Call filter_EE Case "Filter PS" Call filter_PS Case "Filter CRE" Call filter_CRE Case "kein Filter" Call AutofilterRücksetzen End Select 'gemerkte Sprints wiederherstellen Select Case Worksheets("Hilfe").Range("F3").Value Case "3-Wochen-Sprints" '3 Wochen Sprint Call TasksAusblenden Case "alle Sprints" 'alle Sprints Call TasksEinblenden Case "aktueller Sprint" 'aktueller Sprint Call AktuelleTasks End Select Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

bestimmte Anzahl an Zeilen kopieren und einfügen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

361 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

bestimmte Anzahl an Zeilen kopieren und einfügen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

361 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread