AW: bestimmten Teil kopieren und löschen
30.01.2019 14:35:28
Werner
Hallo Andre,
vielleicht ja mit anschließendem Sortieren? Kann ich aber nicht abschließend beantworten, ich kenne deine Formeln ja leider nicht.
Public Sub Verschieben()
Dim strSuche As String, loLetzte As Long
Application.ScreenUpdating = False
strSuche = Application.InputBox("Suchbegriff eingeben:", "Archivieren")
If strSuche "Falsch" Then
If Not strSuche = vbNullString Then
With Worksheets("Hilfe")
If WorksheetFunction.CountIf(.Columns(2), strSuche) > 0 Then
loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(4, 2), .Cells(loLetzte, 13)).AutoFilter field:=1, _
Criteria1:=strSuche
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Columns(12) = Date
.Offset(1).Resize(.Rows.Count - 1).Copy
End With
With Worksheets("Erledigt")
.Cells(.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Row, 2).PasteSpecial _
Paste:=xlPasteValues
Application.CutCopyMode = False
End With
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Columns(12).ClearContents
.Offset(1).Resize(.Rows.Count - 1, .Columns.Count - 6).ClearContents
End With
.Range(.Cells(4, 2), .Cells(loLetzte, 13)).AutoFilter
.Sort.SortFields.Add Key:=Range("B5:B" & loLetzte), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hilfe").Sort
.SetRange Range("B4:G" & loLetzte)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Else
MsgBox "Der Suchbegriff wurde nicht gefunden."
End If
End With
End If
End If
End Sub
Gruß Werner