ich komme einfach nicht weiter bei meiner benötigten Datei und bevor ich jetzt ganz verzweifle meine Bitte an Euch eine Blick darauf zu werfen. Ihr habt bestimmt die Lösung dafür.
Beim Schließen der Excel Datei soll in der "Tabelle1aktiv" jeder Datensatz der ein
Datum in der Spalte I hat in die "Tabelle2archiv" verschoben werden.
Das ist ein paarmal beim Schließen gut gegangen und jetzt bekomme ich die Fehlermeldung:
-2147417848 Die Methode Insert für das Objekt Range ist fehlgeschlagen.
Im Debugger wird diese Zeile ausgegeben "ZielWs.Rows(Fz).Insert"
Aufgerufen wird das Modul in "Diese Arbeitsmappe" als Call bei "Private Sub Workbook_BeforeClose"
Ich weiß mein Code ist nicht professionell (hoffentlich auch nicht zu beschämend) - da ich learning by doing betreibe.
Vielen, vielen Dank für eure Hilfe.
Hier mein Code
Sub Verschieben()
Option Explicit
Sub Verschieben()
'markierte Zeilen auf Arbeitsblatt "Archiv - STRAkleidung" verschieben
Dim WB As Workbook
Dim QuellWs As Worksheet
Dim ZielWs As Worksheet
Dim i As Integer 'Schleifenzähler
Dim Spalte As String
Dim Lz As Long 'letzte beschriebene Zeile
Dim Fz As Long 'erste leere Zeile (nach letzter beschriebener Zeile)
Set WB = ThisWorkbook
Set QuellWs = Tabelle1aktiv 'Worksheets("Aktiv - STRAkleidung")
Set ZielWs = Tabelle2archiv 'Worksheets("Archiv - STRAkleidung")
On Error GoTo FehlerExit
Application.ScreenUpdating = False
QuellWs.Activate
If QuellWs.ProtectContents = True Then
QuellWs.Unprotect "Kontrolle"
If QuellWs.FilterMode Then
QuellWs.ShowAllData
End If
End If
ZielWs.Activate
If ZielWs.ProtectContents = True Then
ZielWs.Unprotect "Kontrolle"
If ZielWs.FilterMode Then
ZielWs.ShowAllData
End If
End If
QuellWs.Activate
'Markierte Zeilen
For i = 10 To QuellWs.Cells(Rows.Count, 1).End(xlUp).Row
If QuellWs.Cells(i, 6).Value "" Or QuellWs.Cells(i, 9).Value "" Then
QuellWs.Rows(i).Copy
'Arbeitsblatt "ZielWs" letzte verwendete Zeile ermitteln
ZielWs.Activate
Spalte = "A" 'Spalte, in der die letzte Zeile ermittelt werden soll
'ermittelt letzte beschriebene Zeile
Lz = ZielWs.Cells(Rows.Count, Spalte).End(xlUp).Row
'ermittelt letzte beschriebene und danach erste freie Zeile (+1)
Fz = ZielWs.Cells(Rows.Count, Spalte).End(xlUp).Row + 1
'in erste freie Zeile, mit Formatierung einfügen und Inhalt leeren
ZielWs.Rows(Fz).Insert
ZielWs.Range("D" & Fz).FormatConditions.Delete 'Zellfüllung entfernen
If ZielWs.Range("D" & Fz).Value = "" Then
With ZielWs.Range("D" & Fz).Interior
.Pattern = xlUp
.PatternThemeColor = xlThemeColorLight1
.ColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
ZielWs.Range("E" & Fz).FormatConditions.Delete 'Ampelfunktion entfernen
Application.CutCopyMode = False
QuellWs.Activate
If QuellWs.Cells(i, 9).Value "" Then
Rows(i).Delete
Else
QuellWs.Cells(i, 6).Copy
QuellWs.Cells(i, 4).PasteSpecial Paste:=xlPasteValues
QuellWs.Cells(i, 6).ClearContents
End If
End If
Next i
FehlerExit:
ZielWs.Protect "Kontrolle", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowDeletingRows:=True _
, AllowSorting:=True, AllowFiltering:=True
QuellWs.Activate
i = 0
Spalte = ""
Lz = 0
Fz = 0
Set WB = Nothing
Set QuellWs = Nothing
Set ZielWs = Nothing
Application.ScreenUpdating = True
'Wenn ein Fehler auftritt - Ausgabe mit Fehlerort, -nummer und Beschreibung
If Err.Number 0 Then MsgBox "Bitte Programmierer informieren mit folgenden Angaben!!!" & _
vbCrLf & vbCrLf & _
"Fehler im Modul - StraArchiv: " & vbCrLf & "Fehlernummer.: " & Err.Number & vbCrLf & _
"Fehlerbeschreibung: " & Err.Description
End Sub