Hilfe, Werte verschwinden aus Datenbank
20.07.2006 09:53:14
Markus
ich habe ein großes Problem:
Ich habe eine Art Datenbank in der ich über eine Eingabemaske (Eingabe -Formular) Werte eingebe, die Werte in einer anderen Tabelle (Daten) mittels Verknüpfung in einer bestimmten Reihenfolge wiedergebe , im Block kopiere und in eine weitere Tabelle einfüge (in die nächts freie Zeile).
Ich habe solche Datenbanken in verschiedenen Bereichen eingerichtet. Das Problem ist nun, daß es vereinzelt Probleme gibt, das Daten eines Tages aus unerklärlichen Gründen gelöscht werden. Zuerst hatte ich Eingabefehler vermutet, daran lag es leider aber nicht.
Das MAkro habe ich mir aus verschiedenen Hilfestellungen von hier zusammengestrickt. Ist hier vielleicht ein Fehler versteckt, der dies auslösen kann? Bite dringend um Hilfe, da mir wichtige daten verloren gehen...
Option Explicit
Const MSGNONR As String = "Archivieren ist ohne Datum nicht möglich"
Const MSGNREXIST As String = "Es besteht bereits ein Eintrag für dieses Datum! Soll ein weiterer Eintrag zu diesem Datum erfolgen?"
Sub Abfrage()
If Sheets("Eingabe-Formular").Range("Datum") <= Date Then
Call Archivieren_Protokoll_Leer
End If
End Sub
Sub Archivieren_Protokoll_Leer()
Dim TBf As Worksheet, TBa As Worksheet, ZZ As Range, Erg, i As Integer
Set TBa = ThisWorkbook.Worksheets("Daten (2)")
Set TBf = ThisWorkbook.Worksheets("Eingabe-Formular")
If IsEmpty(TBf.[Datum]) Then 'Wenn kein Datum
MsgBox (MSGNONR)
Exit Sub
End If
If IsEmpty(TBf.[F2]) Then 'Wenn kein Datum
MsgBox (MSGNONR)
Exit Sub
End If
Set ZZ = TBa.Columns(36).Find(what:=TBf.[Kontrolle].Value)
If ZZ Is Nothing Then
Set ZZ = TBa.Cells(16384, 1).End(xlUp).Offset(1, 0) 'Zeile für Eintragung
Else
If Not MsgBox(MSGNREXIST, vbQuestion + vbYesNo) = vbYes Then Exit
Sub 'Eintrag nicht aktualisieren
End If
Range("Datum").Select
Selection.Copy
Range("J18").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Range("K18").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Speichert aktuelles Protokoll im Archiv
Sheets("Daten").Visible = True
Sheets("Daten").Select
Range("A2:AJ2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Daten (2)").Visible = True
Sheets("Daten (2)").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False ', Transpose:=True
Calculate
'Sortieren
Range("A1:AJ6400").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Ausblenden
Sheets("Daten").Visible = False
Sheets("Daten (2)").Visible = False
Sheets("Eingabe-Formular").Select
Application.ScreenUpdating = False 'Bildschirmaktualisierung aus
'Löscht Inhalte im Protokoll
Range("LöFormular").Select
Selection.ClearContents
Sheets("Eingabe-Formular").Range("Datum").Value = Sheets("Eingabe-Formular").Range("J18")
Range("C3").Select
ActiveWorkbook.Save
End Sub
Danke
MArkus