Speichern in eine datei mit mehreren Teilnehmern

Private Sub CommandButton1_Click() Workbooks.Open "M:\WPA\GAEeingabe\VerlusteVundL.xlsx" Sheets("tabelle1").Cells(65536, 1).End(xlUp).Offset(1, 0) = TextBox1.Text Sheets("tabelle1").Cells(65536, 1).End(xlUp).Offset(0, 1) = TextBox11.Text Sheets("tabelle1").Cells(65536, 1).End(xlUp).Offset(0, 2) = TextBox10.Text ActiveWorkbook.Close True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Dim sPath$, nReturn% sPath = "M:\WPA\GAEeingabe\VerlusteVundL.xlsx" '0 = nicht verwendet, 1 = Schreibgeschützt, 2 = nicht vorhanden nReturn = TestOpen(sPath) Do While nReturn 0 If nReturn = 2 Then Exit Do 'nicht gefunden End If Application.Wait Now + TimeSerial(0, 0, 1) DoEvents nReturn = TestOpen(sPath) Loop If nReturn = 1 Then With Workbooks.Open(sPath) If .ReadOnly = False Then With .Sheets("tabelle1") .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = TextBox1.Text .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1) = TextBox11.Text .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2) = TextBox10.Text End With .Close True Else .Close False MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es später!" End If End With ElseIf nReturn = 2 Then MsgBox "Datei nicht gefunden!" End If End Sub Function TestOpen(sFile As String) As Integer If Dir(sFile, vbNormal) = "" Then TestOpen = 2 Else On Error GoTo ERRORHANDLER Open sFile For Random Access Read Lock Read Write As #99 Close #99 End If ERRORHANDLER: If Err.Number = 70 Then TestOpen = 1 End Function

Private Sub CommandButton1_Click() Dim sPath$, nReturn% sPath = "M:\WPA\GAEeingabe\VerlusteVundL.xlsx" '0 = nicht verwendet, 1 = Schreibgeschützt, 2 = nicht vorhanden nReturn = TestOpen(sPath) Do While nReturn 0 If nReturn = 2 Then Exit Do 'nicht gefunden End If Application.Wait Now + TimeSerial(0, 0, 1) DoEvents nReturn = TestOpen(sPath) Loop If nReturn = 0 Then With Workbooks.Open(sPath) If .ReadOnly = False Then With .Sheets("tabelle1") .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = TextBox1.Text .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1) = TextBox11.Text .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2) = TextBox10.Text End With .Close True Else .Close False MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es später!" End If End With ElseIf nReturn = 2 Then MsgBox "Datei nicht gefunden!" End If End Sub Function TestOpen(sFile As String) As Integer If Dir(sFile, vbNormal) = "" Then TestOpen = 2 Else On Error GoTo ERRORHANDLER Open sFile For Random Access Read Lock Read Write As #99 Close #99 End If ERRORHANDLER: If Err.Number = 70 Then TestOpen = 1 End Function

Function TestOpen(sFile As String) As Integer If Dir(sFile, vbNormal) = "" Then TestOpen = 2 Else On Error GoTo ERRORHANDLER Open sFile For Random Access Read Lock Read Write As #99 Close #99 End If ERRORHANDLER: If Err.Number = 70 Then TestOpen = 1 End Function

Hallo,
habe dir hier das Kennwort mit eingebaut.
Einmal zum Öffnen und einmal fürs Schreiben,
entsprechend anpassen bzw. rauslöschen was nicht benötigt wird.
Zudem habe ich nicht einen Zähler mit eingebaut sollte die Datei länger als 10 Sekunden
nicht frei sein, dann steigt der Code aus.

Private Sub CommandButton1_Click()
Dim sPath$, nReturn%, iTimer%
Const ObenKennwort$ = "christian"
Const SchreibLeseKennwort$ = "christian"
'max Wartezeit
iTimer = 10
'Pfad
sPath = "M:\WPA\GAEeingabe\VerlusteVundL.xlsx"
'0 = nicht verwendet, 1 = Schreibgeschützt, 2 = nicht vorhanden
nReturn = TestOpen(sPath)
Do While nReturn  0
If nReturn = 2 Then
Exit Do 'nicht gefunden
End If
If iTimer = 0 Then Exit Do 'Zeit abgelaufen
Application.Wait Now + TimeSerial(0, 0, 1)
DoEvents
iTimer = iTimer - 1
nReturn = TestOpen(sPath)
Loop
If nReturn = 0 Then
Application.DisplayAlerts = False
With Workbooks.Open(sPath, ReadOnly:=False, Password:=ObenKennwort, WriteResPassword:= _
SchreibLeseKennwort, IgnoreReadOnlyRecommended:=True)
If .ReadOnly = False Then
With .Sheets("tabelle1")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = TextBox1.Text
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1) = TextBox11.Text
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2) = TextBox10.Text
End With
.Close True
Else
.Close False
MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es später!"
End If
End With
Application.DisplayAlerts = True
ElseIf nReturn = 2 Then
MsgBox "Datei nicht gefunden!"
ElseIf nReturn = 1 Then
MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es später!"
End If
End Sub
Function TestOpen(sFile As String) As Integer
If Dir(sFile, vbNormal) = "" Then
TestOpen = 2
Else
On Error GoTo ERRORHANDLER
Open sFile For Random Access Read Lock Read Write As #99
Close #99
End If
ERRORHANDLER:
If Err.Number = 70 Then TestOpen = 1
End Function

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Speichern in eine datei mit mehreren Teilnehmern

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Speichern in eine datei mit mehreren Teilnehmern

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread