Über Schaltfläche Zeilen in ein Anderes Blatt verschieben
15.05.2024 15:01:15
Micha1184
ich hab hier schon ein sehr gutes Makro für meine Anwendung gefunden.
Nur leider bekomm ich das nicht in einem Modul zum laufen so das ich es mit einer Schaltfläche verbinden kann.
ZIEL: Wenn in einer Zelle der Spalte J "Erledigt" drin steht sollen diese Zeilen aus Blatt 1 in Blatt 2 durch drücken der Schaltfläche verschoben werden.
Das Erledigt wird nicht unbedingt immer nach einander stehen also (Zeile: 1;2;5;7;8;25) d.h. es muss auch noch nach dem Erledigt gesucht werden.
Es wäre nett wenn mir hier jemand Helfen könnte.
Ich versuch gerade schon sehr viel aber ich bekomm es leider nicht so umgebaut das ich es als Modul verwenden kann.
Und mit der Suchfunktion hab ich zwar nen Ansatz aber glaub der haut auch nicht so hin wie gedacht:
So nun das was ich habe:
Verschieben der Zeile:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim loLetzteQuelle As Long
Dim loLetzteZiel As Long
Application.ScreenUpdating = False
If Target.Column = 10 Then
cancel = True
loLetzteQuelle = Cells(Rows.Count, 2).End(xlUp).Row
loLetzteZiel = Worksheets("ERLEDIGT").Cells(Rows.Count, 1).End(xlUp).Row + 1
If Target.Row > 1 And Target.Row loLetzteQuelle + 1 Then
If Target Is Nothing Then Exit Sub
If Target = "a" Then
Application.EnableEvents = False
Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Copy
Worksheets("ERLEDIGT").Cells(loLetzteZiel, 1).PasteSpecial xlPasteValues
Cells(Target.Row, 11).Copy Worksheets("ERLEDIGT").Cells(loLetzteZiel, 11)
Application.CutCopyMode = False
With Worksheets("ERLEDIGT").Range("A" & loLetzteZiel & ":K" & loLetzteZiel)
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
Target.EntireRow.Delete shift:=xlUp
loLetzteZiel = Worksheets("ERLEDIGT").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("ERLEDIGT").Columns("A:K")
Worksheets("ERLEDIGT").Sort.SortFields.Clear
Worksheets("ERLEDIGT").Sort.SortFields.Add Key:=Range("A2:A" & loLetzteZiel), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With ActiveWorkbook.Worksheets("ERLEDIGT").Sort
.SetRange Range("A1:K" & loLetzteZiel)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
.SortFields.Clear
End With
Application.EnableEvents = True
End If
End If
End If
Application.ScreenUpdating = True
End Sub
Suchen ob "Erledigt" in Spalte J
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range
If Not Intersect(Target, Columns(10)) Is Nothing Then
If Target.Cells(1) = "Erledigt" Then
Application.EnableEvents = False
For Each rngZelle In Target
If Not Intersect(rngZelle, Columns(10)) Is Nothing Then
..... ( Bin mir nicht sicher wie es hier weiter gehen könnte)
End If
Next rngZelle
Application.EnableEvents = True
End If
End If
End SubDanke euch schon mal für die Unterstützung
Anzeige