ich habe eine Datei mit dem Namen "EMailVersand.xlsm" mit einem Arbeitsblatt "versendete Mails" .
Die Tabelle enthält 7 Spalten.
In der 3. Zeile stehen die Überschriften sodass die eingetragenen Daten ab Zeile 4 beginnen.
Da sich durch die Menge an Einträgen die Laufzeit des Programms zunehmend verlängert gibt es eine
zweite Datei mit dem Namen "EMailArchiv.xlsm" mit dem gleichen Aufbau.
Ich möchte nun erreichen, dass wenn ich in der Datei "EMailVersand.xlsm" in Zelle A1 ein bestimmtes Datum
eingebe, alle Einträge die älter sind als das in A1 angegebene Datum in die Datei "EMailArchiv.xlsm" auf dem Arbeitsblatt "Archiv" unter
die bereits vorhandenen Einträge angefügt werden.
Die Daten sollen also aus der Datei "EMailVersand.xlsm" entfernt und in die Datei "EMailArchiv.xlsm" eingefügt werden.
nachdem keiner an den Thread rangegangen ist habe ich mir die Sache mal angeschaut. Bitte mal das Beispiel testen.
Du musst aber vorher im Makro im Modul1 noch deinen Ordnerpfad per Hand eintragen. Da steht noch mein Testpfad drin!
Wenn du in die Zelle A1 das Datum noch mal neu eingibst wird das Archiv still geöffnet, kopiert, geschlossen, und die Beispieldaten müssten im Archiv erscheinen. Ich denke noch einfacher kann die Lösung nicht sein. Würde mich freuen wenn alles einwandfrei klappt.
Sub Daten_archivieren()
Dim AC As Range, Datum As Date, lz1 As Long
Dim Archiv As Worksheet, j As Long, lzA As Long Set Archiv = Workbooks("EMailArchiv.xlsm").Worksheets("versendete Mails")
With ThisWorkbook.Worksheets("versendete Mails")
On Error GoTo Fehler
'** Hier bitte Ihren Ordnerpfad angeben!!
Workbooks.Open Filename:="H:\DE\Bremen\Garden\Front Office\Module\Backup\EMailArchiv.xlsm"
Windows("EMailVersand.xlsm").Activate
'Schleife zum Daten ins Archiv kopieren
For Each AC In .Range("A3:A" & lz1)
If CDate(AC.Cells(1, 1)) < Datum Then
AC.Resize(1, 7).Copy Archiv.Cells(lzA, 1)
AC.Resize(1, 7).ClearContents
Application.CutCopyMode = False
lzA = lzA + 1
End If
Next AC
'Schleife zum alte Daten rückwärts löschen
Application.EnableEvents = False
For j = lz1 To 3 Step -1
If .Cells(j, 1) = Empty Then .Rows(j).Delete shift:=xlUp
Next j
Application.EnableEvents = True
Workbooks("EMailArchiv.xlsm").Save
Workbooks("EMailArchiv.xlsm").Close
End With
Exit Sub
Fehler: Application.EnableEvents = True
MsgBox "Fehler beim Archivieren aufgetreten" & vbLf & "Stimmt der Ordnerpfad?"
End Sub
An dieser Stelle tritt ein Fehler auf "außerhalb des gültigen Bereichs" Set Archiv = Workbooks("EMailArchiv.xlsm").Worksheets("versendete Mails")
du hast recht, kleiner dummer Programmierfehler! Die Set Anweisung gehört HINTER Workbook.Open, die Datei muss dafür geöffnet sein!
Denke bitte daran bei Workbook.Open deinen Ordnerpfad anzugeben! Da steht noch mein Testordner drin!
mfg Gast 123
Code:
With ThisWorkbook.Worksheets("versendete Mails")
On Error GoTo Fehler
Application.ScreenUpdating = False
'** Hier bitte Ihren Ordnerpfad angeben!!
Workbooks.Open Filename:="D:\Excel Forum\EMailArchiv.xlsm"
Set Archiv = Workbooks("EMailArchiv.xlsm").Worksheets("versendete Mails")
usw.
dann bitte hier noch mal schauen. Fängt bei dir das 1. Datum in Zeile 3 oder in Zeile 4 an? Ggf. den Range Bereich auf 4 korrigieren.
For Each AC In .Range("A4:A" & lz1)
Allerdings befinden sich die Spalte mit dem Datum jetzt in Spalte G
wie muß ich den Code anpassen?
Datum = CDate(.Range("A1")) 'Datum laden lz1 = .Cells(Rows.Count, 1).End(xlUp).Row lzA = Archiv.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Schleife zum Daten ins Archiv kopieren
For Each AC In .Range("G4:G" & lz1) If CDate(AC.Cells(1, 1)) = Datum Then AC.Resize(1, 7).Copy Archiv.Cells(lzA, 1) AC.Resize(1, 7).ClearContents Application.CutCopyMode = False lzA = lzA + 1 End If Next AC 'Schleife zum alte Daten rückwärts löschen Application.EnableEvents = False For j = lz1 To 3 Step -1 If .Cells(j, 1) = Empty Then .Rows(j).Delete shift:=xlUp Next j Application.EnableEvents = True
For Each AC In .Range("G4:G" & lz1) If CDate(AC.Cells(1, 7) = Datum Then AC.Resize(1, 7).Copy Archiv.Cells(lzA, 1) AC.Resize(1, 7).ClearContents Application.CutCopyMode = False
...... Das sollte es gewesen sein (von Cells(1,1) auf Cells (1, 7)
Aber versuche doch auch mal einfach Formeln zu verstehen, notfalls lernen durch probieren.
Daten als Archiv in andere Datei anfügen
