Zeilen verschieben wenn Erledigt.

Private Sub Worksheet_Change(ByVal Target As Range) ' abgeschlossener Punkt verschieben Dim rngBereich As Range Dim rngZelle As Range Dim loLetzte As Long Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten Set rngBereich = Intersect(Target, Range("J:J")) If Not rngBereich Is Nothing Then loLetzte = Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row ' letzte belegte _ in Spalte A (1) On Error GoTo ErrorHandler For Each rngZelle In rngBereich If rngZelle.Value = 1 Then Range("A" & Target.Row & ":J" & Target.Row).Copy Sheets("Archiv").Range("A" & loLetzte + 1).PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A" & Target.Row & ":J" & Target.Row).ClearContents Range("A" & Target.Row).FormulaR1C1 = "=ROW(RC1)-ROW(R3C1)" End If Next rngZelle ErrorHandler: Application.ScreenUpdating = True 'Bildschirmaktualisierung wieder einschalten If Err Then MsgBox Err.Number & " " & Err.Description 'Fehlercode und Beschreibung _ anzeigen End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ylmz,
hier mal eine Idee zur Verfeinerung Deines Codes.
Konnte ich allerdings nicht bis ins letzte testen, da ich jetzt weg muss.

Option Explicit

Option Compare Text

Dim iLastRow As Long

Private Sub Worksheet_Change(ByVal Target As Range)

 Dim Target As Range

   '

   ' abgeschlossener Punkt verschieben

   '

 Dim rngBereich                As Range

 Dim rngZelle                  As Range

 Dim loLetzte                  As Long

   '

 Set Target = ActiveCell

 Application.ScreenUpdating = False     'Bildschirmaktualisierung ausschalten

 Set rngBereich = Intersect(Target, Range("M:M"))

 If Not rngBereich Is Nothing Then

      loLetzte = Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row ' letzte belegte in Spalte A (1)

      On Error GoTo ErrorHandler

      iLastRow = 0

      For Each rngZelle In rngBereich

         If rngZelle.Value Like "erledigt" Then

            iLastRow = rngZelle.Row

            Rows(rngZelle.Row).Copy

            Sheets("Archiv").Range("A" & loLetzte + 1).PasteSpecial Paste:=xlPasteValues, _

            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            Rows(rngZelle.Row).Delete

         End If

      Next rngZelle

ErrorHandler:

   Application.ScreenUpdating = True    'Bildschirmaktualisierung wieder einschalten

   If Err Then MsgBox Err.Number & "  " & Err.Description  'Fehlercode und Beschreibung anzeigen

 End If

End Sub

Sub LetztesProjektZurueck()

 Dim loLetzte As Long

 If iLastRow = 0 Then

  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1

 End If

 loLetzte = Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row ' letzte belegte in Spalte A (1)

 Sheets("Archiv").Rows(loLetzte).Copy

 Range("A" & iLastRow).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

 Range("A" & iLastRow).PasteSpecial Paste:=xlPasteValues, _

         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 Sheets("Archiv").Rows(loLetzte).Delete

End Sub

Viele Grüße aus Freigericht
Karl-Heinz

Private Sub Worksheet_Change(ByVal Target As Range) ' abgeschlossener Punkt verschieben Dim rngBereich As Range Dim rngZelle As Range Dim loLetzte As Long Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten Set rngBereich = Intersect(Target, Range("M:M")) If Not rngBereich Is Nothing Then loLetzte = Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row ' letzte belegte in Spalte _ A (1) On Error GoTo ErrorHandler iLastRow = 0 For Each rngZelle In rngBereich If rngZelle.Value Like "erledigt" Then iLastRow = rngZelle.Row Rows(rngZelle.Row).Copy Sheets("Archiv").Range("A" & loLetzte + 1).PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Rows(rngZelle.Row).Delete End If Next rngZelle End Sub()

Hallo zusammen,
@Fred:
Für eine Aktivierung per Button kannst Du eine der unten aufgeführten Makros nutzen und die einem Button zuordnen.
Hier ist mir nicht klar, ob nur die gerade aktive Zeile, die mit "erledigt" gekennzeichnet ist verschoben werden soll, oder alle in der Spalte "M" markierten Zeilen verschoben werden sollen.
Probier halt aus, was Dir am besten passt.
@Ylms:
Aufgrund der zunächst fehlenden Datei, stelle ich erst jetzt fest, dass das angepasste Makro so nicht funktionieren kann.
Dieses fügt im Archiv unterhalb des "intelligenten Bereich" ein, also auch außerhalb der Formatierung, außerdem gibt die LetzteZeilenermittlung in Spalte 1 immer nur 1 heraus, weil in Spalte "A" keine Daten sind.
Da Du mit dem Change-Event arbeitest, frage ich mich, ob bei Dir nicht auch eine Einzelabarbeitung (also nicht in Schleife die ganze Spalte "M" durchgehen) besser wäre.
Die letzte verschobene Zeilenposition merkt sich das Programm und kann daher das Projekt wieder zurückschieben.
2. Wie verschiebe ich die zeilen wieder zurück auf die Aktuelle Tabelle?
Wenn Du wirklich mehrere Zeilen wieder zurückschieben willst, wird es aufwändig, denn das muss sich ja irgendwie gemerkt werden.
Außerdem benötigt Du einen Starter hierfür, z.B. einen Button, oder ein Eventmanager im Archiv, z.B. wenn man das "erledigt" wieder weg nimmt.
Wenn Du noch etwas Geduld aufbringst, kann ich versuchen, das in Deine Datei einzubauen. Könnte aber etwas dauern.....

Sub EineZeileInsArchivVerschieben()

 Dim loLetzte As Long

 Application.ScreenUpdating = False     'Bildschirmaktualisierung ausschalten

 loLetzte = Sheets("Archiv").Cells(65000, 2).End(xlUp).Row ' letzte belegte in Spalte A

 On Error GoTo ErrorHandler

 If ActiveCell.Column = 13 And ActiveCell.Row &GT; 12 Then

  iLastRow = 0

  If ActiveCell.Value Like "erledigt" Then

    iLastRow = ActiveCell.Row

    Rows(iLastRow).Copy

    Sheets("Archiv").Range("A" & loLetzte + 1).PasteSpecial Paste:=xlPasteValues, _

    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Rows(iLastRow).Delete

  End If

 End If

ErrorHandler:

 Application.ScreenUpdating = True    'Bildschirmaktualisierung wieder einschalten

 If Err Then MsgBox Err.Number & "  " & Err.Description  'Fehlercode und Beschreibung anzeigen

End Sub

Sub MehrereZeilenInsArchivVerschieben()

 Dim rngZelle   As Range

 Dim loLetzte   As Long

 Application.ScreenUpdating = False     'Bildschirmaktualisierung ausschalten

 loLetzte = Sheets("Archiv").Cells(65000, 2).End(xlUp).Row ' letzte belegte in Spalte A (1)

 On Error GoTo ErrorHandler

 iLastRow = 0

 For Each rngZelle In Range("M:M")

     If rngZelle.Value Like "erledigt" Then

        iLastRow = rngZelle.Row

        Rows(iLastRow).Copy

        Sheets("Archiv").Range("A" & loLetzte + 1).PasteSpecial Paste:=xlPasteValues, _

        Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        Rows(iLastRow).Delete

        loLetzte = loLetzte + 1

     End If

 Next rngZelle

ErrorHandler:

 Application.ScreenUpdating = True    'Bildschirmaktualisierung wieder einschalten

 If Err Then MsgBox Err.Number & "  " & Err.Description  'Fehlercode und Beschreibung anzeigen

End Sub

Viele Grüße aus Freigericht
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Zeilen verschieben wenn Erledigt.

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

14 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen verschieben wenn Erledigt.

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

14 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread