Daten als Archiv in andere Datei anfügen

[FrankyHB]

Hallo zusammen,

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.

Kann mir jemand von euch vielleicht weiterhelfen?

Gruß Frank

[Gast 123]

Hallo

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.

mfg Gast 123

[FrankyHB]

Hallo, erst einmal Danke für deine Hilfe,

leider klappt es jedoch nicht.

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
       
    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("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")

Gruß Frank

[Gast 123]

Hallo Frank

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.

[FrankyHB]

Hallo, Vielen Dank,

es klappt schon besser, aber dennoch tritt ein Fehler auf


'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


Fehlermeldung: Typen unverträglich

[Gast 123]

Hallo Frank

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)

mfg  Gast 123

[FrankyHB]

Das erste Datum steht in Zeile 4

---

Ja, jetzt klappt es !!!

Vielen Dank, Gruß Frank

[FrankyHB]

Hallo, ich hab doch noch mal eine Frage,

ich mußte das Arbeitsblatt etwas umgestalten.

Das Datum für die Auswahl steht noch auf A1

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


Vielen Dank schon mal im Voraus

Gruß Frank

[Rudi'S]

Hallo Frank,

ändere einfach den Spaltenbezug

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.

Gruß Rudi

[FrankyHB]

Danke, super das passt.
Gruß Frank