AW: Makro Verschieben von Zeilen in ein Archiv und löschen
31.10.2024 07:51:21
MCO
Hallo Stephan!
Wenn ich mir das so anschaue, hatte dein Vorgänger auch nur eingeschränkt Ahnung.
Grund für den Fehler ist
a) Es wird im "Archiv" kein Autofilter gesetzt, jedoch gefiltert. (der ist aber auch nicht nötig, da der Filter nur gesetzt wird um sofort wieder gelöscht zu werden.)
b) Es wird auf Referenzbereich "Target" verwiesen, den gibt es aber nicht.
Dein neues Makro ist etwas kompakter:
Sub Archiv_neu()
Dim cut_rng As Range
If [Numarchiv].Value >= 1 Then
With Sheets("Logbuch")
.Unprotect "logadmin"
Sheets("Archiv").Unprotect "logadmin"
Sheets("Archiv").Range("a6:A" & [Numarchiv].Value + 5).EntireRow.Insert
If .FilterMode Then .ShowAllData 'Filter löschen
.Range("A5").AutoFilter Field:=24, Criteria1:=">" 'filter auf nicht leer (nicht "X"!)
Set cut_rng = .Range("A6:A" & .Range("A6").CurrentRegion.Rows.Count).SpecialCells(xlCellTypeVisible) 'betroffene Zeilen benennen
Application.EnableEvents = False
For Each zeil In cut_rng 'zeilen durchgehen
trgt = trgt + 1
With .Range("A" & zeil.Row & ":X" & zeil.Row)
.Copy Sheets("Archiv").Range("A5").Offset(trgt, 0) 'absichtlich nur copy, da sich sonst die Zeilen verschieben
.ClearContents 'löschen der Inhalte
End With
Next zeil
Application.EnableEvents = True
.Protect "logadmin"
Sheets("Archiv").Protect "logadmin"
End With
End If
End Sub
Statt beim Makro "Alle zeigen" erste einen Filter zu setzen nur um alle zu löschen könnte man einfach den Status abfragen und nur ggf. löschen:
Sub alle_zeigen()
With ActiveSheet
.Unprotect "logadmin" 'enleve la protection de la page
If .FilterMode Then .ShowAllData 'Filter löschen
.Protect "logadmin", DrawingObjects:=True, _
Contents:=True, Scenarios:=True, _
AllowFormattingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowFiltering:=True
End With
End Sub
im Private Sub Worksheet_Change(ByVal Target As Range) der Tabelle 1 schau dir mal die Möglichkeit "select case" an.
Wesentlich übersichtlicher als if then else
Select Case Target.Column
Case 4
'ausführen
Case 8, 16
'ausführen
Case 18
Case Else
'alles andere
End Select
Gruß, MCO