SImultan in 2 Dateien schreiben

Option Explicit

Const PathB = "F:\Test\TestB.xls"  

Dim ChangeA As Boolean

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
    If Sh Is Sheets("Tabelle1") And Source.Address Like "*$A$*" Then ChangeA = True  
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim WkbB As Workbook, WksA As Worksheet, WksB As Worksheet
    
    If ChangeA Then
        On Error GoTo Fehler
    
        Application.ScreenUpdating = False
                
        Set WksA = ActiveWorkbook.Sheets("Tabelle1")  
        Set WkbB = Workbooks.Open(PathB):  Set WksB = WkbB.Sheets("Tabelle1")  
        
        WksA.Range("A:A").Copy Destination:=WksB.Range("A:A")  
        
        WkbB.Save:  WkbB.Saved = True:  WkbB.Close:  ChangeA = False
    
        Application.ScreenUpdating = True
    End If
Exit Sub

Fehler:
    Application.ScreenUpdating = True
    MsgBox "Datei " & PathB & " nicht gefunden!", vbExclamation, "Fehler"  
End Sub