bestimmte Anzahl an Zeilen kopieren und einfügen

VBA · 2018-08-23T14:52:48+00:00

Hallo, ich habe folgendes Makro um eine bestimmte Zeile zu kopieren. Es wird jeweils die Zeile kopiert, in der sich die markierte Zelle befindet. Anschließend kommen 3 Abfragen, um einen bestimmten Text zu übernehmen oder zu ändern. Dies funktioniert soweit sehr gut, allerdings immer nur für eine Markierung (also auch nur für eine Zeile) Mein Anliegen: ich würde gerne mehrere Zellen (1 Zelle pro Zeile) markieren und das Makro geht die Anzahl der Zeilen nach und nach durch. Leider sind meine Fähigkeiten hier begrenzt. Kann mir jemand hier helfen und das Makro umbauen? Vielen Dank Gruß 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 Fil

Hallo,
versuche es mal so:

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

In dem eingefügten For Each-Block werden die einzelnen Zellen der Markierung durchlaufen und die jeweilige Zeile kopiert und eine Zeile tiefer eingefügt. Da ich vermute, dass die neue Zeile die alte nicht überschreiben soll, habe ich dort die Insert-Anweisung verwendet. Wenn also z. B. die Zelle B3 markiert ist, wird die Zeile 3 kopiert und zwischen der Zeile 3 und 4 eingefügt. Die alte Zeile 4 ist dann Zeile 5. Soll es anders sein, so wie in Deinem Makro, dass also die alte Zeile 4 in dem Fall mit einer Kopie der Zeile 3 überschrieben werden soll, muss die Codezeile

cl.Offset(1, 0).EntireRow.Insert shift:=xlShiftDown

ActiveSheet.Paste Destination:=cl.Offset(1, 0).EntireRow

geändert werden.
Um den Zellen mit den Abfragen neue Werte zu geben, müssen die nicht extra mit Select ausgewählt werden. Außerdem habe ich die ganzen If..then-Anweisungen in zwei Select Case-Anweisungen geändert, das finde ich übersichtlicher.
Schau Dir es mal an.
Gruß
Robert

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

bestimmte Anzahl an Zeilen kopieren und einfügen

Forumthread: bestimmte Anzahl an Zeilen kopieren und einfügen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial