Automatisch Speichern/Schließen Makro

[Victor]

Moin zusammen,

ich komme mal wieder nicht weiter und benötige eure Unterstützung:

Derzeit haben wir ein Formular fürs Testen von unseren Geräten. 
Die ganzen Daten werden, sofern sich ein Fehler ergibt, in eine Archiv Datei gezogen. 
Nach Freigabe des Formulars werden dann die Daten vom Formular gelöscht und ein PDF-Zertifikat erzeugt. 

Wenn die Daten (automatisch) im Formular eingegeben werden, werden bereits die entsprechenden fehlerhaften Zeilen in die Archiv Datei kopiert.
Diese muss nur noch gespeichert und wieder geschlossen werden. Hier ist aber nun mein Problem, denn mit meinem Code funktioniert es nicht :(
Mein Gedanke war es, dass beim verändern von Spalte M (letzter Eintrag) wird die Datei gespeichert und geschlossen.

Mein Code im Archiv sieht so aus:

Sub SaveAndClose()
    Dim wb As Workbook
   
    Set wb = ThisWorkbook
   
    wb.Save
    wb.Close SaveChanges:=False

End Sub


Private Sub Aufpassen

    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Columns("M"))

    If Not AffectedRange Is Nothing Then
          SafeAndClose

    End If
End Sub

Oder soll im Makro aus dem Formular etwas geändert werden?

[HKindler]

Hi,

deine
Private Sub Aufpassen
müsste eigentlich
Private Sub Worksheet_Change(ByVal Target As Range)
heißen und im Modul des entsprechenden Arbeitsblattes stecken.

Aber Achtung! Dann wird mit jeder Änderung in Spalte M diese Datei gespeichert und geschlossen. Ich glaube nicht, dass es das ist, was du haben willst...

Ich würde ja eher sagen, dass dein Hauptmakro (jenes welches die automtisierten Einträge acht) am Besten weiß, wenn es fertig ist und dann dein Archiv schließen sollte...

[Victor]

Ich danke dir schonmal Helmut. Wie kann ich am besten mein "Kopier" Markro ändern? Code ist hier:

Sub Ausfallprotokoll()
    Dim ws As Worksheet ' Tabellenblatterkennung
    Dim wsArchiv As Worksheet ' Zieltabellenblatt
    Dim wsData As Worksheet ' Tabellenblatt "Data"
    Dim lastRow As Long ' Letzte Zeile in Messung
    Dim nextRow As Long ' Nächste freie Zeile im Zieltabellenblatt
    Dim i As Long ' Zählvariable
    Dim AnzahlBloeckeString As Long ' Anzahl der zu prüfenden Blöcke
    Dim savePath As String ' Speicherpfad für die Datei
   
    Set ws = ThisWorkbook.Sheets("Messung")
    Set wsData = ThisWorkbook.Sheets("Data")
    Set wsArchiv = Workbooks.Open("G:\ABC\Anleitungen\Messung_Archiv.xlsm").Sheets("Datenbank")
   
    nextRow = wsArchiv.Cells(wsArchiv.Rows.Count, 1).End(xlUp).Row + 1
   
    ' Anzahl der zu prüfenden Blöcke (hier ein Beispielwert, bitte entsprechend anpassen)
    AnzahlBloeckeString = ws.Range("I12").Value
   
    ' Überprüfung der Zeilen in Messung
    With ws
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row ' Letzte Zeile in Spalte B
        For i = 13 To lastRow - AnzahlBloeckeString
            If Not IsEmpty(.Range("B" & i & ":B" & i + AnzahlBloeckeString).Value) Then
                ' Prüfung nach "r" in Spalte C oder E
                If InStr(1, .Range("C" & i).Value, "r", vbTextCompare) > 0 Or _
                  InStr(1, .Range("E" & i).Value, "r", vbTextCompare) > 0 Then
                    ' Kopieren der relevanten Daten ins Zieltabellenblatt
                    wsArchiv.Cells(nextRow, 1).Value = .Range("B9").Value
                    wsArchiv.Cells(nextRow, 2).Value = .Range("B4").Value
                    wsArchiv.Cells(nextRow, 3).Value = .Range("B5").Value
                    wsArchiv.Cells(nextRow, 4).Value = (i - 12)
                    wsArchiv.Cells(nextRow, 5).Value = .Range("B" & i).Value
                    wsArchiv.Cells(nextRow, 6).Value = .Range("D" & i).Value
                    wsArchiv.Cells(nextRow, 7).Value = .Range("B6").Value
                    wsArchiv.Cells(nextRow, 8).Value = .Range("B7").Value
                    wsArchiv.Cells(nextRow, 9).Value = .Range("B8").Value
                    wsArchiv.Cells(nextRow, 10).Value = .Range("H" & i).Value
                    wsArchiv.Cells(nextRow, 11).Value = wsData.Range("E2").Value
                    wsArchiv.Cells(nextRow, 12).Value = wsData.Range("E4").Value
                    wsArchiv.Cells(nextRow, 13).Value = wsData.Range("E5").Value
                   
                    nextRow = nextRow + 1 ' Nächste freie Zeile im Zieltabellenblatt aktualisieren
                End If
            End If
        Next i
    End With
   
    ' Speichern der Datei <- Dies hier funktioniert leider nicht.
    'savePath = "G:\ABC\Anleitungen\Messung_Archiv.xlsx"
    'archiveWorkbook.SaveAs savePath
    'archiveWorkbook.Close SaveChanges:=False
   
Ende
   
End Sub

[HKindler]

Hi,

Code:

...
End With
wsArchiv.Parent.Close SaveChanges:=True
Ende
End Sub

[derHoepp]

Moin,

Das zugehörige WorkbookObjekt zu einem Worksheet Objekt findest du über die .Patent-Eigenschaft:

Code:

wsArchiv.Parent.Close true

Viele Grüße
derHöpp