Office: mehrere Anwender sollen per Makro Daten in freigegener Datei speichern

Hallo,

folgendes Problem:

mehrere Anwender haben lokale Dateien mit Makro, die als Erfassungsmsske dienen. Mittels eines Buttons, der das makro aufruft, sollen diese den Inhalt der erfassten Felder in eine zentrale freigegebene Tabelle speichern. Mit meinen beschränkten VBA-Kenntnissen habe ich das so gelöst:

Code:

Sub Speichern()

  Dim Pfad As String
  Dim Dateiname As String
  Dim erste_freie_Zeile As Integer
  Application.ScreenUpdating = False
  Pfad = "O:\Test\"
  Dateiname = Dir(Pfad & "Zentraldatei.xls")
  Workbooks.Open Filename:=Pfad & Dateiname
  'suchen der ersten freien Zeile
  erste_freie_Zeile = Workbooks(Dateiname).Sheets("Sammlung").Range("A65536").End(xlUp).Offset(1, 0).Row

  'Schreibe Datum und Uhrzeit in die erste Spalte der freien Zeile
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 1).Value = Now
  
  'Eintragen der erfassten Daten
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 2) = ThisWorkbook.Sheets("Kundenservice").Range("B2").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 3) = ThisWorkbook.Sheets("Kundenservice").Range("B3").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 4) = ThisWorkbook.Sheets("Kundenservice").Range("B4").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 5) = ThisWorkbook.Sheets("Kundenservice").Range("B5").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 6) = ThisWorkbook.Sheets("Kundenservice").Range("B6").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 7) = ThisWorkbook.Sheets("Kundenservice").Range("B7").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 8) = ThisWorkbook.Sheets("Kundenservice").Range("B8").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 9) = ThisWorkbook.Sheets("Kundenservice").Range("B9").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 10) = ThisWorkbook.Sheets("Kundenservice").Range("C9").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 11) = ThisWorkbook.Sheets("Kundenservice").Range("D9").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 12) = ThisWorkbook.Sheets("Kundenservice").Range("B10").Value
  Workbooks(Dateiname).Sheets("Sammlung").Cells(erste_freie_Zeile, 13) = ThisWorkbook.Sheets("Kundenservice").Range("B11").Value
  Workbooks(Dateiname).Save
  MsgBox "Daten wurden gespeichert", vbInformation, "Speichern erledigt"
  Workbooks(Dateiname).Close
  Dateiname = Dir()
Application.ScreenUpdating = True

End Sub

Das Makro öffnet die freigegebene Datei, sucht die nächste freie Zeile und befüllt in dieser dann einige Felder.

Sobald mehrere Anwender sehr schnell hintereinander und parallel Erfassungen durchführen, kommt es zu Konfiktmeldungen. Der Anwender bekommt die Meldung, dass die kollidierende Änderung eines anderen Anwenders für die gleiche Zelle vorliegt.

Meien Vermutung ist, dass in der kurzen Zeitspanne (zwischen dem Ermitteln der freien Zeile und dem darauf folgenden Eintragen der Daten) das Makro eines anderen Anwender die gleiche freie Zeile ermittelt.

Meine VBA-Kenntnisse sind beschränkt (bin mehr Jäger und Sammler...), so dass ich nicht weiss, ob und wie das Problem umgangen werden kann. Meine Idee ist, dass die Datei immer nur von einem Anwender zur Zeit geöffnet werden kann, und dass ein anderer, der während dieser Zeit auch das Speichern() Makro aufruft, in einer Art 'Warteschleife' bleibt. Er soll keine Fehlermeldung bekommen, sondern das Makro soll warten, bis die Datei wieder geschlossen ist, und es dann erneut versuchen. Ob das dann mit 15 Anwendern, die im schlimmsten Fall alle gleichzeitig eine Erfassung vornehmen wollen, noch stabil und ohne lange Wartezeiten läuft, weiss ich natürlich nicht.

 

Hallo Dr. Seltsam,

für die von Dir gewünschte Aufgabe schlage ich den unten folgenden Code vor.
Sollte eigentlich alles klappen, komplett testen kann ich es aber gerade nicht, da ich hier kein Netzwerk habe.

Es gibt 2 Voraussetzungen:

1. Die Zentraldatei darf nicht für die Bearbeitung durch mehrere Nutzer gleichzeitig freigegeben sein.
2. Auf den User-PCs ist die Fehlerbehandlung für Makros auf "Bei nicht verarbeiteten Fehlern" eingestellt (Fenster des Makroeditors - Extras - Optionen - Allgemein - Unterbrechen bei Fehlern)

Arbeitsweise des Makros:

• prüfen ob die Zentraldatei unter dem angegeben Pfad überhaupt existiert, falls nein > Abbruch
• Testweise prüfen ob die Zentraldatei geöffnet werden kann und Ergebnis auswerten
  [*=1]ist sie geöffnet, warten und erneut versuchen, solange bis es klappt
  [*=1]ist sie nicht geöffnet, Datei öffnen, Daten eintragen und speichern

Damit nicht endlos versucht wird die Datei zu öffnen und der Rechner dadurch lahmgelegt wird, kannst Du in dieser Zeile

Code:

loTry = 10

einstellen, wie oft es versucht werden soll, bevor der User mittels Messagebox die Möglichkeit zum Abbruch erhält.

Mit dieser Zeile

Code:

Application.Wait Now + TimeSerial(0, 0, 1)

kannst Du einstellen, wie lange das Makro zwischen zwei Versuchen wartet. Momentan ist eine Sekunde eingestellt.

Um den Vorgang für den User ein klein wenig zu gliedern (je nachdem wie lange alles dauert), zeigt die Statusbar (unten links im Excelfenster) zwei Zustände an:

1. Zentraldatei wird geöffnet
2. Daten werden gespeichert

Code:

Option Explicit

Sub Speichern()

Dim loFreieZeile As Long
Dim loCounter As Long
Dim loTry As Long
Dim strPfad As String
Dim strDatName As String
Dim strMsgBox As String
Dim wsQuelle As Worksheet

loCounter = 0
loTry = 10
strPfad = "O:\Test\"
strDatName = "Zentraldatei.xls"

' Überprüfung ob die Zentraldatei momentan geöffnet ist, bzw. überhaupt existiert
    If Dir(strPfad & strDatName) = "" Then
    ' Datei existiert nicht
        MsgBox "Die Datei:    " & strDatName & vbNewLine & vbNewLine & "konnte im angegebenen Ordner nicht gefunden werden:" & vbNewLine & vbNewLine & strPfad & vbNewLine & vbNewLine & "Der Speichervorgang wird abgebrochen!", vbCritical, "Abbruch"
        Exit Sub
    Else
    ' Datei existiert
        Application.StatusBar = strDatName & " wird geöffnet"
        Application.ScreenUpdating = False
PrüfungObGeöffnet:
        On Error GoTo 0
        Do
            loCounter = loCounter + 1
            If loCounter > loTry Then
            ' Notausgang, um dem User zu ermöglichen den Vorgang abzubrechen
                Application.ScreenUpdating = True
                strMsgBox = MsgBox(loTry & " Versuche zu speichern sind bereits fehlgeschlagen." & vbNewLine & _
                    "Möchten Sie es zu einem späteren Zeitpunkt nocheinmal probieren?", vbRetryCancel, "Speichern fehlgeschlagen")
                If strMsgBox = vbCancel Then
                    MsgBox "Der Speichervorgang wurde durch den Benutzer abgebrochen.", vbOKOnly, "Abbruch"
                    Application.StatusBar = False
                    Exit Sub
                Else
                    Application.ScreenUpdating = False
                    loCounter = 1
                End If
            End If
        ' Test-Versuch die Datei zu öffnen, ist sie bereits offen ergibt sich Fehler 70
            On Error Resume Next
            Open (strPfad & strDatName) For Random Access Read Lock Read Write As #1
            Close #1
            If Err = 70 Then
            ' Datei ist geöffnet, ab in die Warteschleife und erneut versuchen
                On Error GoTo 0
                Application.Wait Now + TimeSerial(0, 0, 1)
                GoTo PrüfungObGeöffnet
            Else
            ' Datei öffnen, tritt dabei ein Fehler auf, erneut in die Schleife
                On Error GoTo PrüfungObGeöffnet:
                Workbooks.Open Filename:=strPfad & strDatName
                On Error GoTo 0
                Application.StatusBar = "Daten werden gespeichert"
                Exit Do
            End If
        Loop
    End If

' Datei wurde erfolgreich geöffnet, Daten können also übernommen werden
    Set wsQuelle = ThisWorkbook.Worksheets("Kundenservice")
    With Workbooks(strDatName).Worksheets("Sammlung")
    ' erste freie Zeile ermitteln
        loFreieZeile = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
    ' Datum und Uhrzeit in die erste Spalte der freien Zeile schreiben
        .Cells(loFreieZeile, 1).Value = Format(Now, "dd/mm/yyyy hh:mm:ss")
    ' erfasste Daten eintragen
        .Cells(loFreieZeile, 2) = wsQuelle.Range("B2").Value
        .Cells(loFreieZeile, 3) = wsQuelle.Range("B3").Value
        .Cells(loFreieZeile, 4) = wsQuelle.Range("B4").Value
        .Cells(loFreieZeile, 5) = wsQuelle.Range("B5").Value
        .Cells(loFreieZeile, 6) = wsQuelle.Range("B6").Value
        .Cells(loFreieZeile, 7) = wsQuelle.Range("B7").Value
        .Cells(loFreieZeile, 8) = wsQuelle.Range("B8").Value
        .Cells(loFreieZeile, 9) = wsQuelle.Range("B9").Value
        .Cells(loFreieZeile, 10) = wsQuelle.Range("C9").Value
        .Cells(loFreieZeile, 11) = wsQuelle.Range("D9").Value
        .Cells(loFreieZeile, 12) = wsQuelle.Range("B10").Value
        .Cells(loFreieZeile, 13) = wsQuelle.Range("B11").Value
    End With
    Workbooks(strDatName).Close SaveChanges:=True
    Set wsQuelle = Nothing
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "Daten wurden gespeichert", vbInformation, "Speichern erledigt"

End Sub

Wenn Du etwas nicht verstehst, erkläre ich es Dir gerne.


Ich hoffe geholfen zu haben.

 

Guten Morgen Achim,

vielen lieben Dank! Ich war Freitag nicht im Büro und werde heute mal checken, ob "Bei nicht verarbeiteten Fehlern" die Standardeinstellung auf unseren PCs ist.

Hast Du vielleicht noch eine Idee, wie man die erste Prüfung darauf erweitern könnte, ob ein Zugriffsrecht auf die Zentraldatei bzw. das entsprechende Verzeichnis besteht?

Gruß
Martin

 

Hallo Martin,

das allereinfachste wäre meiner Meinung nach, eine MsgBox inklusive Makro-Abbruch, falls ein anderer Fehler als Nr. 70 auftreten sollte.
Das muss dann zwar nicht unbedingt mit den Zugriffsrechten zusammen hängen, aber es wird die Fehlernummer angezeigt und der User bekommt den Hinweis sich an seinen Admin zu wenden.

Dies könnte man wie folgt lösen (Achtung: folgender Code ist nur ein Teil des ganzen!):

Code:

        ' Test-Versuch die Datei zu öffnen, ist sie bereits offen ergibt sich Fehler 70
            On Error Resume Next
            Open (strPfad & strDatName) For Random Access Read Lock Read Write As #1
            Close #1
            If Err = 70 Then
            ' Datei ist geöffnet, ab in die Warteschleife und erneut versuchen
                On Error GoTo 0
                Application.Wait Now + TimeSerial(0, 0, 1)
                GoTo PrüfungObGeöffnet
            [COLOR=#ff0000]ElseIf Err <> 0 Then
            ' alle anderen Fehler > möglicherweise fehlende Zugriffsrechte
                On Error GoTo 0
                Application.ScreenUpdating = True
                MsgBox "Der Fehler Nr. " & Err.Number & " ist aufgetreten." & vbNewLine & "Bitte wenden Sie sich an Ihren Systemadministrator." & vbNewLine & "Der Vorgang wird abgebrochen.", vbCritical, "Abbruch"
                Application.StatusBar = False
                Exit Sub[/COLOR]
            Else

Ich hoffe geholfen zu haben.

 

Hallo Achim,

bislang funktioniert alles so wie ich es möchte!

Ein kleines Problem hatte ich noch, wenn der Anwender für den Netzwerkordner, in dem die Zentraldatei liegt, keine Zugriffsrechte hat: Dann crasht der Code bereits in der Zeile

Code:

If Dir(strPfad & strDatName) = "" Then

mit Laufzeitfehler 52 (Dateiname oder -nummer falsch)

Setze ich ein "On Error Resume Next" darüber, dann kommt die übliche Meldung, dass die Datei im angegebenen Ordner nicht gefunden werden konnte. Anscheinend gibt es keine Unterscheidung zwischen nicht vorhandenen Pfaden/Dateien und solchen, die zwar vorhanden sind, aber für die Zugriffsrechte fehlen.

Ich habe dann nochmal separat folgendenden Block vorgeschoben:

Code:

    On Error Resume Next
    If Dir(strPfad & strDatName) <> "" And Err = 52 Then
    ' fehlende Zugriffsrechte
        MsgBox "Für die Datei:    " & strDatName & vbNewLine & vbNewLine & "fehlen Ihnen die Zugriffsrechten:" & _
        vbNewLine & vbNewLine & strPfad & vbNewLine & vbNewLine & "Bitte informieren Sie Ihren Systemadministrator", vbCritical, "Abbruch"
        Exit Sub
    End If

Muss ich die normale Fehlerbehandlung danach noch wieder anschalten, oder ist mein "On Error Resume Next" nur für diese separate If-Schleife gültig?

Gruß
Martin

 

Hallo Martin,

Doch, durch die Überprüfung mit "If Dir(strPfad & strDatName) = "" Then" wird kein Laufzeitfehler ausgelöst wenn die Datei nicht existiert. Fehlen aber die Zugriffsrechte, so wird ein Fehler ausgelöst.

Der Modus der Fehlerbehandlung ist immer solange gültig, bis er ausgeschaltet oder geändert wird. "If-Schleifen", "With-Anweisungen" oder sonstige ähnlichen Befehle haben darauf keinerlei Auswirkung (wär ja auch nervig und unlogisch).

Deshalb jaaaaanz wichtig!!! :
Benutzt man "On Error Resume Next", nie vergessen die normale (oder eine eigene) Fehlerbehandlung wieder einzuschalten, denn ansonsten werden alle auftretenden Fehler einfach ignoriert und der Code läuft unkontrolliert durch.

Das wird hier sehr gut erklärt:
http://www.online-excel.de/excel/singsel_vba.php?f=147


Um jetzt eine Unterscheidung zwischen "Datei nicht gefunden" und "keine Zugriffsberechtigung" zu erreichen und auszuwerten, würde ich den folgenden Code vorschlagen:

Code:

' Überprüfung ob die Zentraldatei existiert und Zugriffsberechtigung besteht
    [COLOR=#ff0000]On Error Resume Next[/COLOR]
    If Dir(strPfad & strDatName) = "" Then
        [COLOR=#ff0000]If Err = 52 Then
        ' fehlende Zugriffsrechte
            On Error GoTo 0
            MsgBox "Sie haben keine Zugriffsrechte für die Datei:" & vbNewLine & vbNewLine & strPfad & strDatName & vbNewLine & vbNewLine & "Bitte informieren Sie Ihren Systemadministrator." & vbNewLine & vbNewLine & "Der Vorgang wird abgebrochen.", vbCritical, "Zugriff verweigert"
            Exit Sub
        Else[/COLOR]
        ' Datei existiert nicht
            [COLOR=#ff0000]On Error GoTo 0[/COLOR]
            MsgBox "Die Datei:    " & strDatName & vbNewLine & vbNewLine & "konnte im angegebenen Ordner nicht gefunden werden:" & vbNewLine & vbNewLine & strPfad & vbNewLine & vbNewLine & "Der Speichervorgang wird abgebrochen!", vbCritical, "Abbruch"
            Exit Sub
        [COLOR=#ff0000]End If[/COLOR]
    Else
    ' Datei existiert und Zugriffsberechtigung besteht
        [COLOR=#ff0000]On Error GoTo 0[/COLOR]
        Application.StatusBar = strDatName & " wird geöffnet"
        Application.ScreenUpdating = False

Möglicherweise muss der Fehlerabfang für Nr 52 aber auch unter "Datei existiert".
Das kann ich hier jetzt so nicht testen. Kannst Du aber im Einzelschrittmodus schnell prüfen, und angepasst solltest Du es ja jetzt auch bekommen, oder?


Und damit es nicht total unübersichtlich wird, hier nochmal der komplette Code:

Code:

Option Explicit

Sub Speichern()

Dim loFreieZeile As Long
Dim loCounter As Long
Dim loTry As Long
Dim strPfad As String
Dim strDatName As String
Dim strMsgBox As String
Dim wsQuelle As Worksheet

loCounter = 0
loTry = 10
strPfad = "O:\Test\"
strDatName = "Zentraldatei.xls"

' Überprüfung ob die Zentraldatei existiert und Zugriffsberechtigung besteht
    On Error Resume Next
    If Dir(strPfad & strDatName) = "" Then
        If Err = 52 Then
        ' fehlende Zugriffsrechte
            On Error GoTo 0
            MsgBox "Sie haben keine Zugriffsrechte für die Datei:" & vbNewLine & vbNewLine & strPfad & strDatName & vbNewLine & vbNewLine & "Bitte informieren Sie Ihren Systemadministrator." & vbNewLine & vbNewLine & "Der Vorgang wird abgebrochen.", vbCritical, "Zugriff verweigert"
            Exit Sub
        Else
        ' Datei existiert nicht
            On Error GoTo 0
            MsgBox "Die Datei:    " & strDatName & vbNewLine & vbNewLine & "konnte im angegebenen Ordner nicht gefunden werden:" & vbNewLine & vbNewLine & strPfad & vbNewLine & vbNewLine & "Der Speichervorgang wird abgebrochen!", vbCritical, "Abbruch"
            Exit Sub
        End If
    Else
    ' Datei existiert und Zugriffsberechtigung besteht
        On Error GoTo 0
        Application.StatusBar = strDatName & " wird geöffnet"
        Application.ScreenUpdating = False
    
PrüfungObGeöffnet:
        On Error GoTo 0
        Do
            loCounter = loCounter + 1
            If loCounter > loTry Then
            ' Notausgang, um dem User zu ermöglichen den Vorgang abzubrechen
                Application.ScreenUpdating = True
                strMsgBox = MsgBox(loTry & " Versuche zu speichern sind bereits fehlgeschlagen." & vbNewLine & _
                    "Möchten Sie es zu einem späteren Zeitpunkt nocheinmal probieren?", vbRetryCancel, "Speichern fehlgeschlagen")
                If strMsgBox = vbCancel Then
                    MsgBox "Der Speichervorgang wurde durch den Benutzer abgebrochen.", vbOKOnly, "Abbruch"
                    Application.StatusBar = False
                    Exit Sub
                Else
                    Application.ScreenUpdating = False
                    loCounter = 1
                End If
            End If
        ' Test-Versuch die Datei zu öffnen, ist sie bereits offen ergibt sich Fehler 70
            On Error Resume Next
            Open (strPfad & strDatName) For Random Access Read Lock Read Write As #1
            Close #1
            If Err = 70 Then
            ' Datei ist geöffnet, ab in die Warteschleife und erneut versuchen
                On Error GoTo 0
                Application.Wait Now + TimeSerial(0, 0, 1)
                GoTo PrüfungObGeöffnet
            ElseIf Err <> 0 Then
            ' alle anderen Fehler
                On Error GoTo 0
                Application.ScreenUpdating = True
                MsgBox "Der Fehler Nr. " & Err.Number & " ist aufgetreten." & vbNewLine & "Bitte wenden Sie sich an Ihren Systemadministrator." & vbNewLine & "Der Vorgang wird abgebrochen.", vbCritical, "Abbruch"
                Application.StatusBar = False
                Exit Sub
            Else
            ' Datei öffnen, tritt dabei ein Fehler auf, erneut in die Schleife
                On Error GoTo PrüfungObGeöffnet:
                Workbooks.Open Filename:=strPfad & strDatName
                On Error GoTo 0
                Application.StatusBar = "Daten werden gespeichert"
                Exit Do
            End If
        Loop
    End If

' Datei wurde erfolgreich geöffnet, Daten können also übernommen werden
    Set wsQuelle = ThisWorkbook.Worksheets("Kundenservice")
    With Workbooks(strDatName).Worksheets("Sammlung")
    ' erste freie Zeile ermitteln
        loFreieZeile = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
    ' Datum und Uhrzeit in die erste Spalte der freien Zeile schreiben
        .Cells(loFreieZeile, 1).Value = Format(Now, "dd/mm/yyyy hh:mm:ss")
    ' erfasste Daten eintragen
        .Cells(loFreieZeile, 2) = wsQuelle.Range("B2").Value
        .Cells(loFreieZeile, 3) = wsQuelle.Range("B3").Value
        .Cells(loFreieZeile, 4) = wsQuelle.Range("B4").Value
        .Cells(loFreieZeile, 5) = wsQuelle.Range("B5").Value
        .Cells(loFreieZeile, 6) = wsQuelle.Range("B6").Value
        .Cells(loFreieZeile, 7) = wsQuelle.Range("B7").Value
        .Cells(loFreieZeile, 8) = wsQuelle.Range("B8").Value
        .Cells(loFreieZeile, 9) = wsQuelle.Range("B9").Value
        .Cells(loFreieZeile, 10) = wsQuelle.Range("C9").Value
        .Cells(loFreieZeile, 11) = wsQuelle.Range("D9").Value
        .Cells(loFreieZeile, 12) = wsQuelle.Range("B10").Value
        .Cells(loFreieZeile, 13) = wsQuelle.Range("B11").Value
    End With
    Workbooks(strDatName).Close SaveChanges:=True
    Set wsQuelle = Nothing
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "Daten wurden gespeichert", vbInformation, "Speichern erledigt"

End Sub

Ich hoffe geholfen zu haben.

 

Hallo Achim,

vielen lieben Dank! So funktioniert es prima!

Gruß
Martin