|
Ich habe das VBA nochmals reinkopiert und hoffe damit geht es besser.
Option Explicit
'Dateiname der Datenbank
Public Const Dateiname = "G:Datenbanken\alte Datenbanken\Analytik_Stabilität.mdb"
Dim Datenbank As Database
Dim Datensatz As Recordset
Dim Tabelle As TableDef
Dim x, y, Spaltenanfang, Spaltenende, Feldanfang, Feldende As Integer
Dim Tabellenname1 As String
Dim strSuchstring As String
Dim strFieldKey As String
Dim strsql As String
Dim leerzeichenabfrage As Integer
Public intabbruch As Integer
Dim malvern As String
Dim Feldnamenspalte As Integer
'Versuchsdaten in die Datenbank schreiben
Public Sub Analytik_schreiben()
If Range("b10").Value <> "0" Then
'Spaltenanfang, Spaltenende, Zeilenstart, Zeilenende, Tabellenname1
Daten_schreiben_Funktion 2, 11, 10, 15, "Analytik_Stabilität"
Else
Exit Sub
End If
End Sub
'Suspensionsdaten in die Datenbank schreiben
Public Sub Daten_schreiben_Funktion(Spaltenanfang As Integer, Spaltenende As Integer, Feldanfang As Integer, Feldende As Integer, Tabellenname1 As String)
Set Datenbank = OpenDatabase(Dateiname)
intabbruch = 0
Worksheets("Deckblatt").Select
'Spalte wo die Feldnamen drin stehen
Feldnamenspalte = 1
'Prüfen, Tabelle existiert
If Not TableExists(Dateiname, Tabellenname1) Then
MsgBox "Datenbank oder Tabelle ist nicht vorhanden !", vbExclamation
intabbruch = 1
Exit Sub
End If
'Prüfe ob Datensatz bereits existiert
strFieldKey = Cells(Feldanfang, Feldnamenspalte).Value
strSuchstring = Cells(Feldanfang, Spaltenanfang).Value
strsql = "SELECT * FROM " & Tabellenname1 & " Where " & strFieldKey & "= '" & strSuchstring & "'"
Set Datensatz = Datenbank.OpenRecordset(strsql)
If Datensatz.RecordCount = 0 Then
Set Datensatz = Datenbank.OpenRecordset(Tabellenname1)
With Datensatz
'Spalten
For x = Spaltenanfang To Spaltenende
.AddNew
'Spalten
For y = Feldanfang To Feldende
.Fields(Cells(y, Feldnamenspalte)).Value = Cells(y, x).Value
Cells(y, x).Activate
Next y
'Datensatz updaten
On Error Resume Next
.Update
.Bookmark = .LastModified
Next x
End With
Else
If MsgBox("Datensatz ist bereits vorhanden. Möchten Sie ihn ersetzen?", vbYesNo + vbQuestion) = vbYes Then
'Daten überschreiben
With Datensatz
'Spalten
For x = Spaltenanfang To Spaltenende
.AddNew
'Spalten
For y = Feldanfang To Feldende
.Fields(Cells(y, Feldnamenspalte)).Value = Cells(y, x).Value
Cells(y, x).Activate
Next y
'Datensatz updaten
On Error Resume Next
.Update
.Bookmark = .LastModified
Next x
End With
Else
MsgBox "Vorgang abgebrochen"
intabbruch = 2
End If
End If
Datenbank.Close
End Sub
'Prüft, ob eine Tabelle in einer
'Datenbank bereits vorhanden ist
Public Function TableExists(Dateiname, MyTableName)
Dim i
'Prüfen, ob die Datenbank existiert
If Dir(Dateiname) = "" Then
TableExists = False
MsgBox "Die Datei " & Dateiname & " ist nicht vorhanden"
Exit Function
End If
'Datenbank öffnen
Set Datenbank = OpenDatabase(Dateiname)
TableExists = False
'alle Tabellen durchlaufen
For i = 0 To Datenbank.TableDefs.Count - 1
If Datenbank.TableDefs(i).Name = MyTableName Then
TableExists = True
Exit Function
End If
Next i
Datenbank.Close
End Function
|