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, 21:46 (Dieser Beitrag wurde zuletzt bearbeitet: 17.01.2022, 21: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, 22:37 (Dieser Beitrag wurde zuletzt bearbeitet: 19.01.2022, 22: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.
Hilfe: Anpassen des Codes VBA
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
