AW: Zeile kopieren, wenn Wert in Spalte K gegeben ist
26.06.2013 09:39:43
Tino
Hallo,
bin mir nicht sicher ob Ausschneiden das richtige ist was Du suchst,
weil dadurch in der Quelle die Formatierung gelöscht wird.
Habe beide Varianten eingebaut, kannst die nicht gewollte löschen.
Sub Daten_Ins_Archiv()
Dim rngCut As Range, NextRow&
On Error Resume Next
Set rngCut = Tabelle1.Columns("K:K").SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Not rngCut Is Nothing Then
Application.EnableEvents = False
Set rngCut = rngCut.EntireRow
If MsgBox("Sollen die Daten ins Archiv?", vbYesNo) = vbYes Then
With Sheets("Archiv")
NextRow = FindLetzteZeile(Sheets(.Name))
For Each rngCut In rngCut.Areas
NextRow = NextRow + 1
'Ausschneiden und einfügen
rngCut.Cut .Cells(NextRow, 1)
'oder kopieren und Format und Werte Übertragen
rngCut.Copy
.Cells(NextRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
rngCut.ClearContents
Next rngCut
End With
End If
Application.EnableEvents = True
End If
End Sub
Function FindLetzteZeile(mySH As Worksheet) As Long
Dim LRow As Long
With mySH.UsedRange
On Error Resume Next
'Finde Zeile
LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LRow = 0 Then LRow = 1
End With
FindLetzteZeile = LRow
End Function
Gruß Tino