AW: Zeile ausschneiden und in anderes Blatt verschiebe
04.02.2008 18:31:30
Nepumuk
Hallo Claudia,
so?
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Move_Done_Transactions
Me.Save
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Sub Move_Done_Transactions()
Dim objCell As Range
Dim lngRowsArray() As Long, lngRowCounter As Long, lngCopyRow As Long
Dim strAddress As String
With Worksheets("VWN-Suche")
Set objCell = .Columns(6).Find(What:="erledigt", _
After:=.Columns(6).Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
If Not objCell Is Nothing Then
strAddress = objCell.Address
Do
lngRowCounter = lngRowCounter + 1
Redim Preserve lngRowsArray(1 To lngRowCounter)
lngRowsArray(lngRowCounter) = objCell.Row
Set objCell = .Columns(6).FindNext(objCell)
Loop While Not objCell Is Nothing And objCell.Address <> strAddress
With Worksheets("erledigte Vorgänge")
lngCopyRow = .Cells(.Rows.Count, 6).End(xlUp).Row
End With
For lngRowCounter = UBound(lngRowsArray) To 1 Step -1
lngCopyRow = lngCopyRow + 1
.Rows(lngRowsArray(lngRowCounter)).Cut
Worksheets("erledigte Vorgänge").Rows(lngCopyRow).Insert Shift:=xlDown
.Rows(lngRowsArray(lngRowCounter)).Delete
Next
End If
End With
End Sub
Gruß
Nepumuk