probier bitte mal diesen neuen Code aus, ich denke er wird euch gefallen. Neu ist die MsgBox vor dem kopieren, und die ist gut ausgetüfftelt!
Angeziegt wird Name, Vorname und Geb.Datum des kunden. Darunter die Spalten wo Änderungen sind und der Text in Quelle und Zielsdatei.
Damit habt ihr eine exakte Übersicht was sich an dem jeweiligen Datensatz geändert hat. Und könnt bei evtl. (Tipp) Fehlern mit Nein wegklicken!
Code:
Sub Daten_übertragen()
Dim AC As Range, LSp, s2, z2 As Long
Dim Ziel As Worksheet, i, lz1 As Long
Dim Wbook As Workbook, wdh As Integer, ok
Dim ZTxt As String, Übs As String 'neu eingefügt für MsgBox Meldung
Dim QTxt As String, Kunde As String
With ThisWorkbook.Worksheets("Tabelle1")
' If .Cells(Rows.Count, 26).End(xlUp).Row = 1 Then _
MsgBox "Es sind keine Daten zum kopieren vorhanden": Exit Sub
neu: On Error Resume Next
Set Wbook = Workbooks("Statistik Gesamt.xlsm")
If Not Wbook Is Nothing Then
Application.Wait Now + TimeValue("00:00:01")
wdh = wdh + 1: If wdh < 3 Then GoTo neu
ok = MsgBox("Datei ist durch einen anderen Anwender gesperrt! - 3 Sek. warten??", vbYesNo)
If ok = vbNo Then Exit Sub
Application.Wait Now + TimeValue("00:00:03")
wdh = 0: GoTo neu
End If
On Error GoTo Fehler
Application.ScreenUpdating = False
Workbooks.Open Filename:=Zieldatei
Set Ziel = Workbooks("Zieldatei.xlsx").Worksheets("Tabelle1")
'LastZell in Quelle, LastSpalte in Ziel Tabelle
lz1 = .Cells(Rows.Count, "Z").End(xlUp).Row
LSp = .Cells(1, Columns.Count).End(xlToLeft).Column
'Alle in Z markierten Zeilen ins Ziel kopieren
'** überarbeitet mit Differenz Prüfung vor dem kopieren
For Each AC In .Range("Z2:Z" & lz1)
If LCase(AC) = "x" Then
'MsgBox Text löschen, ok auf vbYes setzen
ZTxt = "": QTxt = "": Übs = "": ok = vbYes
'Prüfe in Zieltabelle Spalte xxx ob Wert vorhanden ist?
If Ziel.Cells(AC.Row, 1) <> "" Then
'Kunden Name und Geb.Datum ermitteln
Kunde = .Cells(AC.Row, 6) & ", " & .Cells(AC.Row, 7) & " " & .Cells(AC.Row, 9)
'Spalten Differenzen ermitteln (Spalte A-T)
For i = 1 To 20
If .Cells(AC.Row, i) <> Ziel.Cells(AC.Row, i) Then
Übs = Übs & ", " & .Cells(1, i)
QTxt = QTxt & ", " & .Cells(AC.Row, i)
ZTxt = ZTxt & ", " & Ziel.Cells(AC.Row, i)
End If
Next i
'Keine Dieffernez ok Abfrage überspringen
If QTxt & ZTxt = "" Then AC.Value = "": GoTo nx
'Quelle + Zieltext aufarbeiten
Übs = Replace(Übs, vbLf, "", xlPart)
Übs = "Spalte: " & Trim(Mid(Übs, 2))
QTxt = "Quelle: " & Trim(Mid(QTxt, 2))
ZTxt = "Ziel: " & Trim(Mid(ZTxt, 2))
Übs = "S" & Replace(Übs, "-", "", xlPart)
'Fehlermeldung mit allen Differnez Daten
ok = MsgBox("Dieser Datensatz ist bereits vorhanden: - Überschreiben?" _
& vbLf & Kunde & vbLf & Übs & vbLf & QTxt & vbLf & ZTxt, vbYesNo)
End If
'Nur bei ybYes Datensatz kopieren
If ok = vbYes Then
.Cells(AC.Row, 1).Resize(1, LSp).Copy
Ziel.Cells(AC.Row, 1).PasteSpecial xlPasteAll
nx: End If
End If
Next AC
Application.CutCopyMode = False
Workbooks("Zieldatei.xlsx").Save 'Speichern
Workbooks("Zieldatei.xlsx").Close 'Schliessen
'Quellspalte Z markierungen löschen
.Range("Z2:Z" & lz1).ClearContents
ActiveSheet.Labels(1).Text = "Keine Daten"
ThisWorkbook.Save
End With
Exit Sub
Fehler: MsgBox "Fehler beim Ziel-Datei Öffnen"
End Sub
PS die Spalten Überschrift und die geänderten Kundendaten lassen sich nicht 1:1 übereinanderbringen. Das kann ich aber nicht ändern!
