Hallo zusammen,

mit dem nachfolgenden Code erfolgt zunächst eine Abfrage ob weitergemacht oder abgebrochen werden soll...

Dann wird aus sFile = strPfad & "z_GA-Daten.xlsm" die Anzahl für den Seriendruck ausgelesen und eine "Bindung" für einen Serienbrief hergestellt.

Der Serienbrief wird gedruckt und ein pdf mit dem Serienbrief erstellt - jeweils nach Abfrage...

Dann möchte ich in diese z_GA-Daten.xlsm eintragen, dass gedruckt wurde und wo undsoweiter

das klappt auch, nur muss die z_GA-Daten.xlsm noch von vorher offen sein oder so, da immer aufgefordert wird, eine Kopie zu speichern.

Wie kriege ich denn die "Bindung" gelöst, dass eben in die z_GA-Daten.xlsm gespeichert werden kann?

Danke

FG

Sub PARTEIEN()
'
 Dim strPfad, vName As String
 Dim vAnz As Integer
 Dim vFrage As Integer
 Dim xlApp As Object
 Dim xlWkb As Object
 Dim sFile As String
 Dim sSheet As String
 
     sSheet = "Parteien"
     vAnz = 1
 
 If MsgBox("Die Anzahl der Drucke wird von vorher übernommen ! " & vbCrLf & vbCrLf & "Soll abgebrochen werden (für Word-Neustart) ? ", vbYesNo + vbQuestion, _
"Danke für die Beachtung aller Sicherheitsmaßnahmen ! ") = vbYes Then Exit Sub ' vFrage = True Else vFrage = False
 
    strPfad = ActiveDocument.path & "\"
    sFile = strPfad & "z_GA-Daten.xlsm"
    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:=sFile _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=strPfadLst;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `Parteien$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
    
    sSheet = "Parteien"
    
    'überprüfen ob File vorhanden
    With CreateObject(Class:="Scripting.FileSystemObject")
        If .fileexists(sFile) Then
            'Datei vorhanden
            Set xlApp = CreateObject(Class:="Excel.Application")
            Set xlWkb = xlApp.Workbooks.Open(sFile)
            'Arbeiten im Excel
            With xlWkb.Worksheets(sSheet)
            vAnz = .Cells(1, 1)
            End With
            'Meldungen unterdrücken
            xlApp.DisplayAlerts = False
            xlWkb.Close SaveChanges:=True
            xlApp.DisplayAlerts = True
            xlApp.Quit
        Else
            'Code wenn Datei nicht vorhanden
        End If
    End With
    '
'    Set xlWkb = Nothing
 '   Set xlApp = Nothing

    DoEvents
      
      vAnz = vAnz - 1
        
      vAnz = InputBox("Anzahl der PARTEIEN", "PARTEIEN", vAnz)
     
     If MsgBox("PDF-Druck ? ", vbYesNo + vbQuestion, _
"Danke für die Beachtung aller Sicherheitsmaßnahmen ! ") = vbYes Then
    
   Application.ScreenUpdating = False
    Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
    Set MainDoc = ActiveDocument
    With MainDoc
    StrFolder = .path & Application.PathSeparator
        
   '  For i = 1 To vAnz '.MailMerge.DataSource.RecordCount
      With .MailMerge
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = 1
        .LastRecord = vAnz
        .ActiveRecord = i
       ' If Trim(.DataFields("Zuname")) = "" Then Exit For
        
       ' StrName = MainDoc.Name
         StrName = Left(MainDoc.Name, Len(MainDoc.Name) - 5)
       '  MsgBox (StrName)
      End With
      .Execute Pause:=False
       
    End With
    StrName = Trim(StrName)
    With ActiveDocument
     ' .SaveAs2 FileName:=StrPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
      ' and/or:
      .SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
' Next i
End With
Application.ScreenUpdating = True

    End If
     
     If MsgBox("PAPIER-Druck ? ", vbYesNo + vbQuestion, _
            "Danke für die Beachtung aller Sicherheitsmaßnahmen ! ") = vbYes Then
            ActivePrinter = "C368"
         With ActiveDocument.MailMerge
            .Destination = wdSendToPrinter
            .SuppressBlankLines = True
        
        With .DataSource
            .FirstRecord = 1
            .LastRecord = vAnz
        End With
        .Execute Pause:=False
    End With
    
    Dim xx As Integer
 vDatum = Date
 
    sFile = ActiveDocument.path & "\" & "z_GA-Daten.xlsm"
    sSheet = "Startblatt"
    
    With CreateObject(Class:="Scripting.FileSystemObject")
        If .fileexists(sFile) Then
            'Datei vorhanden
            Set xlApp = CreateObject(Class:="Excel.Application")
            Set xlWkb = xlApp.Workbooks.Open(sFile)
            'Arbeiten im Excel
            With xlWkb.Worksheets(sSheet)
            For xx = 4 To 500
            vHtxt = .Cells(xx, 6)
            If vHtxt = "" Then
            .Cells(xx, 6) = vDatum
           ' .Cells(xx, 7) = vCopy ' Anzahl der Drucke
            .Cells(xx, 8) = ActiveDocument.Name
          '   .Cells(xx, 9) = vPrinter
            Exit For
            End If
            
            Next
                        
            End With
            'Meldungen unterdrücken
            xlApp.DisplayAlerts = False
            xlWkb.Close SaveChanges:=True
            xlApp.DisplayAlerts = True
            xlApp.Quit
             DoEvents
        Else
            'Code wenn Datei nicht vorhanden
        End If
    End With
    '
    Set xlWkb = Nothing
    Set xlApp = Nothing
    
    DoEvents
     ActiveDocument.Save
    ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
    
   End If
    
End Sub