AW: Verschiedene Rechner greifen gleichzeitig zu
15.08.2017 14:49:30
fcs
Hallo Jonas,
Die lange Laufzeit beim Speichern wird ja hauptsächlich verursacht durch das Speichern der Daten zur Änderungsverfolgung. Wenn du die Detail-Infos zu den Ändeerungen (Wer, wann, wo, was) niht benötigst, dann solltest du alle Änderungen in den Dateien annehmen und beim anschließenden Freigen die Option "Änderungen verfolgen" deaktivieren. Zusätzlich könnten noch aufwendige Berechnungen in den Dateien zur Laufzeit betragen - das bekommt man oft durch Optimierungen in der Programmierung in den Griff..
Ich hab auch ein wenig rumgetüftelt und etwas angepasst, was ich hier in einem Forums-Beitrag gefunden habe. Dabei wird vor dem Speichern geprüft, ob eine Info-Datei (Text) vorhanden ist. Wenn nein, dann wird die kleine Info-Datei erstellt und der Speichervorgangs gestarte. Ist der Speichervorgang abgeschlossen, dann wird die Info-Datei wieder gelöscht.
Startet ein anderer User während des Speichervorgangs auf seinem Rechner das Speichermakro, dann wird der Inhalt der Info-Datei in einer MsgBox angezeigt.
Ich konnte das jetzt nur Lokal testen, indem ich die Info-Datei manuell in das entsprechende Verzeichnis kopiert bzw. dort gelöscht hab.
Wie robust das Ganze dann im Alltagsbetrieb auf einem Netzlaufwerk funktionier: ?
Langfristig sind sicher die alternativen Vorschläge von Martin bzw. Thorsten der bessere Weg.
Gruß
Franz
Private Sub prcDatenSpeichern()
'Daten in die Dateien Daten.xls, Werte.xls, Mitarbeiter.xls schreiben und speichern
Dim StatusCalc As Long
Dim wkbDaten As Workbook, wkbWerte As Workbook, wkbMA As Workbook
Dim intFF As Integer, strDatei As String, varStartSpeichern, strText As String, strMsg As _
String
On Error GoTo Fehler
StatusCalc = Application.Calculation
Set wkbDaten = Workbooks("Daten.xls")
Set wkbWerte = Workbooks("Werte.xls")
Set wkbMA = Workbooks("Mitarbeiter.xls")
'Name der Infodatei zur Anzeige, dass ein andere User zur Zeit Daten speichert
strDatei = wkbDaten.Path & Application.PathSeparator & "Files_in_Use.txt"
ReStart:
If Dir(strDatei) = "" Then
'Start des Speichervorgangs in Textdatei schreiben
intFF = FreeFile
Open strDatei For Output As #intFF
Print #intFF, "User """ & VBA.Environ("Username") & """ bearbeitet zur Zeit die Dateien" _
Print #intFF, "Daten.xls, Werte.xls und Mitarbeiter.xls"
Print #intFF, "mit Makro ""prcSpeichern Daten"", Startzeit: " _
& Format(Now, "YYYY-MM-DD hh:mm:ss")
Close #intFF
'Makrobremsen lösen
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Application.Calculate
'ab hier dann der bisherige Code zum Eintragen der Userform-Daten in die 3 Dateien
'falls zwingend erforderlich, zwischendurch Neuberechnungen einfügen.
'Vor dem Speichern der 3 Dateien alles neu berechnen
Application.Calculate
wkbDaten.Save
wkbWerte.Save
wkbMA.Save
'Textdatei zur Markierung des Speichervorgangs wieder löschen
If Dir(strDatei) "" Then VBA.Kill strDatei
Else
intFF = FreeFile
Open strDatei For Input As #intFF
strMsg = ""
Do Until EOF(intFF)
Line Input #intFF, strText
strMsg = strMsg & vbLf & strText
Loop
Close #intFF
'Startdatum/-Zeit des letzten Speichervorgangs aus Text auslesen
varStartSpeichern = Right(strMsg, 19)
varStartSpeichern = CDate(varStartSpeichern)
'Nach maximal 2 Minuten kann die Markierungsdatei gelöscht und der Speichervorgang _
erneut gestartet werden
If Now - varStartSpeichern > TimeSerial(Hour:=0, Minute:=2, Second:=0) Then
If MsgBox(strMsg & Chr(13) _
& "Der Speichervorgang beim User liegt schon etwas zurück." & vbLf _
& "Info-Datei löschen und Speichervorgang erneut starten?", _
vbOKCancel + vbQuestion, _
"Hinweis:") = vbOK Then
VBA.Kill strDatei
GoTo ReStart:
End If
Else
MsgBox strMsg & Chr(13) _
& "Bitte warten Sie bis das Makro des anderen Users die Dateien wieder zum " _
& "Speichern freigegeben hat!" & vbLf & vbLf _
& "Starten Sie dann den Speichervorgang erneut.", _
vbOKOnly + vbInformation, _
"Hinweis:"
GoTo Fehler
End If
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles in Ordnung
Case 9
MsgBox "Eine der Dateien ""Daten.xls"", ""Werte.xls"" oder " _
& """Mitarbeiter.xls"" ist nicht geöffnet!"
Case Else
MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
Close intFF
End Select
End With
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub