Menü
An- und Abmelden
Partner / Links
Beiträge anzeigen
1
Excel / Antw:Office 2013: Zeilen bei Bedingung in andere Tabelle verschieben
« am: Dezember 13, 2016, 12:12:24 Nachmittag »
Hallo gmg-cc,
danke für den Hinweis, da es sich aber um eine Tabelle handelt in der nur Werte eingegeben werden und keine Änderungen stattfinden möchte ich dies über Excel lösen.
Mittlerweile habe ich "Glück des Dummen?) doch tatsächlich selbst die Lösung gefunden. Falls es jemanden weiterhilft...
In das Arbeitsblatt "offene Forderungen" habe ich folgenden Code eingefügt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim lRow As Long, zRow As Long
On Error GoTo FehlerHandler
lRow = Sheets("offene Forderungen").Range("B" & Rows.Count).End(xlUp).Row
zRow = Sheets("Archiv Forderungen").Range("B" & Rows.Count).End(xlUp).Row + 1
Set Bereich = Sheets("offene Forderungen").Range("F6:F" & lRow)
If Not Intersect(Target, Bereich) Is Nothing Then
If IsDate(Target.Value) = True And Target.Value <> "" Then
With Range("B" & Target.Row & ":G" & Target.Row)
.Copy Destination:=Sheets("Archiv Forderungen").Range("B" & zRow)
Application.EnableEvents = False
.Delete Shift:=xlShiftUp
End With
End If
End If
Application.EnableEvents = True
Exit Sub
FehlerHandler:
Application.EnableEvents = True
End Sub
vielen Dank nochmal an alle die sich Gedanken gemacht haben.
Schöne Grüße Thomas
danke für den Hinweis, da es sich aber um eine Tabelle handelt in der nur Werte eingegeben werden und keine Änderungen stattfinden möchte ich dies über Excel lösen.
Mittlerweile habe ich "Glück des Dummen?) doch tatsächlich selbst die Lösung gefunden. Falls es jemanden weiterhilft...
In das Arbeitsblatt "offene Forderungen" habe ich folgenden Code eingefügt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim lRow As Long, zRow As Long
On Error GoTo FehlerHandler
lRow = Sheets("offene Forderungen").Range("B" & Rows.Count).End(xlUp).Row
zRow = Sheets("Archiv Forderungen").Range("B" & Rows.Count).End(xlUp).Row + 1
Set Bereich = Sheets("offene Forderungen").Range("F6:F" & lRow)
If Not Intersect(Target, Bereich) Is Nothing Then
If IsDate(Target.Value) = True And Target.Value <> "" Then
With Range("B" & Target.Row & ":G" & Target.Row)
.Copy Destination:=Sheets("Archiv Forderungen").Range("B" & zRow)
Application.EnableEvents = False
.Delete Shift:=xlShiftUp
End With
End If
End If
Application.EnableEvents = True
Exit Sub
FehlerHandler:
Application.EnableEvents = True
End Sub
vielen Dank nochmal an alle die sich Gedanken gemacht haben.
Schöne Grüße Thomas
