der einzige Unterschied zu meinem Problem, dass 8 Kollegen die Zielliste ausfüllen. Jeder Kollege besitzt eine Quellliste und speichert die Daten in der Zielliste.
Die Quell- und Zielliste sind identisch. "Siehe den Code im Anhang" Zu meiner Frage: kommt es zu Konflikten, wenn 2 oder 5 Kollegen in der gleichen Sekunde die Daten speichern. Wenn ja? wie kann man das vermeiden? wie kann man den Code anpassen??
Sub IstDateiGeöffnet()
On Error GoTo errhandler
Open Pfad & "Statistik Gesamt.xlsm" For Binary Access Read Lock Read As #1
Close #1
Workbooks.Open Pfad & "Statistik Gesamt.xlsm"
Exit Sub
errhandler:
MsgBox "Datei ist durch einen anderen Anwender gesperrt."
End Sub
interessante Idee von Ralf. Er brachte mich auf die Idee es noch etwas auszubauen. Dieser Code macht eine interne Warteschleife von 3x 1 Sekunde, dann eine MsgBox Abfrage ob man noch mal 3 Sekunden warten will oder Abbrechen. Die Zeiten könnte man auf 1/2 Sekunde kürzen.
mfg gast 123
Code:
Sub IstDateiGeöffnet()
Dim Wbook As Workbook, wdh As Integer, ok
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
Workbooks.Open Pfad & "Statistik Gesamt.xlsm"
End Sub
17.01.2022, 20:46 (Dieser Beitrag wurde zuletzt bearbeitet: 17.01.2022, 20:50 von Juri.)
Guten Abend,
vielen Dank für die Antworten.
Ich habe den Code vom Gast 123 im Modul1 eingebaut aber ein Fehler wurde beim kompilieren angezeigt, dass der Pfad nicht definiert ist. siehe Bild im Anhang.
ich glaube, dass der Pfad als String definiren muss "Dim Pfad As String"
Frage: wenn es so ist, wo soll ich den Code von Gast 123 einbauen?? in Modul1, Modul2 oder Tabelle1??
Ich habe die Excel Datei hochgeladen, damit ihr weißt was zu tun ist.
probier bitte mal ob es mit dem eingebautem Code klappt. Würde mich sehr freuen.
mfg Gast 123
Code:
Sub Daten_übertragen()
Dim AC As Range, LSp, s2, z2 As Long
Dim Ziel As Worksheet, lz1 As Long
Dim Wbook As Workbook, wdh As Integer, ok
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
For Each AC In .Range("Z2:Z" & lz1)
If LCase(AC) = "x" Then
.Cells(AC.Row, 1).Resize(1, LSp).Copy
Ziel.Cells(AC.Row, 1).PasteSpecial xlPasteAll
End If
Next AC
Ich danke Dir sehr „Gast 123“ für die fantastische Lösung. Ich habe den Code getestet und funktioniert einwandfrei. Ich hätte bitte noch eine eine kleine Frage, kann man eine MsgBox im Code einbauen, der folgendes bei der Übertragung der Daten in der Zielliste prüft, ob die Zelle z.B. A2 oder A3 oder A4……..A100 voll oder leer ist. Wenn die Zelle voll ist, dann soll die MsgBox mir die Möglichkeit geben, ob ich die Daten überschreibe oder nicht? Vielen Dank Juri
19.01.2022, 21:37 (Dieser Beitrag wurde zuletzt bearbeitet: 19.01.2022, 21:39 von Gast 123.)
Hallo
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!
mfg Gast 123
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
mir fehlen die Worte, dir zu danken. Du bist einfach genial
Alle Administratoren des Forums sind super nett und hilfsbereit.
Vielen Dank und einen schönen Abend wünsche ich euch.