AW: Zeile nach Beding. in anderes Tabellenblatt versch
20.04.2017 12:47:37
fcs
Hallo Maria,
mit folgendem Makro sollte das Verschieben und Sortieren funktionieren.
Gruß
Franz
Sub ErledigtVerschiebn()
Dim Zeile_Q As Long, Zeile_Z, Zeile As Long, Zeile_L As Long
Dim bolVerschoben As Boolean
Dim StatusCalc As Long, StatusCopyObjects As Boolean
Dim wksQ As Worksheet, wksZ As Worksheet
Set wksQ = ActiveWorkbook.Worksheets("AKTUELL")
Set wksZ = ActiveWorkbook.Worksheets("ERLEDIGT")
With Application
'ggf. Status für Kopieren von Objekten mit Zellen anpassen, damit Schaltflächen mit _
verschoben werden
StatusCopyObjects = Application.CopyObjectsWithCells
If StatusCopyObjects = False Then
Application.CopyObjectsWithCells = True
End If
'Makrobremsen lösen
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wksZ
'letzte Zeile im Zielblatt,, Spalte A
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
Zeile_Z = Zeile_L
End With
With wksQ
'letzte Datenzeile im Quellblatt, Spalte A
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_L > 1 Then
For Zeile_Q = 2 To Zeile_L
If .Cells(Zeile_Q, 10).Text = "a" Then 'erledigt
'Zeile verschieben
Zeile_Z = Zeile_Z + 1
.Rows(Zeile_Q).Cut Destination:=wksZ.Rows(Zeile_Z)
bolVerschoben = True 'Merker, das mindestens eine Zeile verschoben wurde
End If
Next
If bolVerschoben = True Then
'leerzeilen löschen in AKTUELL
With .Range(.Cells(2, 1), .Cells(Zeile_L, 1))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
End With
With wksZ
'Einträge in "ERLEDIGT" nach Datum/Zeit aufsteigend sortieren
With .Range(.Rows(1), .Rows(Zeile_Z))
.Sort Key1:=.Range("B1"), Order1:=xlAscending, _
key2:=.Range("C1"), order2:=xlAscending, Header:=xlYes
End With
End With
End If
MsgBox "F E R T I G", vbOKOnly, "erledigte verschieben"
Else
MsgBox "keine Daten vorhanden in Blatt """ & wksQ.Name & """", _
vbOKOnly, "erledigte verschieben"
End If
End With
With Application
'Status ggf wierde zurücksetzen
If StatusCopyObjects Application.CopyObjectsWithCells Then
Application.CopyObjectsWithCells = StatusCopyObjects
End If
'Makrobremsen zurücksetzen
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub
