Ich, der ich ganz neu in dieser User-Group bin, will auch mal etwas vorstellen, was Ihr vielleicht
gebrauchen könnt.
Ein Änderungsprotokoll.
Die Idee:
Da ich im Kreditwesen (Leiter EDV) arbeite, brauche ich jede Transaktion protokolliert, gleichgültig ob
ich auf Groß-, Midrange-Rechner oder PC (im Standalone oder Netzwerk) arbeite.
Da ich jetzt aber keine Lust habe, alles detailliert zu erklären (wie die Routinen funktionieren),
folgt anschließend die Routine.
Wer Fragen hat, kann sich über max@maxgalle.de an mich wenden.
Es gibt unter Euch aber sicherlich Leute, die mir vielleicht auch den einen oder anderen Hinweis geben
können, wie man das Ding besser realisieren kann.
Ich denke dabei z.B. (dafür habe ich noch keine Lösung gefunden) an die Installation in einem einzigen
Standard-Modul mit Gültigkeit über die gesamte Mappe mit all ihren Blättern.
Wichtig ist, daß das Protokoll nicht in der aktuellen Mappe sondern völlig extern als Textfile gespei-
chert wird.
Wichtig ist ferner die Extension des Protokollfiles: .jgf !
Ein "normaler" User kann das Ding nicht so einfach (mittels Editor) öffnen und ggf. manipulieren.
Einige Highlights:
- sie ist leicht zu installieren
- sie liefert Argumente gegen User-Aussagen wie "Ich habe überhaupt nichts gemacht !!"
- sie schaut nicht nur nach einer einzelen Zellveränderung sondern auch nach kopierten Zellen
- Im Falle von Formeln protokolliert sie die Formel
- protokolliert werden
- vollständiger Pfad und Workbookname
- Blattname
- Benutzer
- Zelladresse
- Zellname
- altem Wert
- neuem Wert
- Datum
- Zeit
- Einzelne Zelle, Bereichskopie oder Initialisierung:
Einzelne Zelle Falsch
Bereichskopie Wahr
Initialisierung Init
- sie erlaubt das Einlesen der Protokolldaten über einen Zeitraum ggf. begrenzt auf einen User
Die Routinen haben aber auch Nachteile:
- Wenn ich Zellen kopiere, kenne ich nicht mehr den vorherigen Wert der entsprechenden Zelle
Man muß halt in den Routinen rummachen, wenn kein BisDatum vorhanden ist.
Also, ich hoffe auf Response.
Und nur die Routine:
'----------------------------------------------------------------------
'
' Den folgenden Code-Teil in das jeweilige Objekt-Modul kopieren und
' aktivieren
'
'#######################################################################
'Option Explicit
'
'Public varValue As Variant
'Public strAddress As String
'Const Pfad = "C:\Temp\"
'
'Private Sub Worksheet_Change(ByVal Target As Range)
' Call wscAP_Change(Target, varValue, Pfad)
'End Sub
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Call wscAP_SelectionChange(varValue, strAddress)
'End Sub
'#######################################################################
Option Explicit
Const Pfad = "C:\Temp\"
Declare Function Get_User_Name Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long
'
Sub wscAP_Change(ByVal Target As Range, varValue, Pfad)
Dim c
Dim f, NewVal, OldVal, Satz, Benutzername, ZName As String
Dim dateiname As String
Dim FileNumber
Dim Bereich As Boolean
FileNumber = FreeFile
dateiname = Pfad & "XL_" & Format(Date, "yyyymmdd") & ".lgf"
Open dateiname For Append As #FileNumber
Benutzername = syGetUserName
Bereich = InStr(1, Target.Address, ":")
For Each c In Target
ZName = ""
On Error Resume Next
ZName = c.Name.Name
OldVal = CStr(varValue)
NewVal = CStr(c.Value)
If c.HasFormula Then NewVal = CStr(c.Formula)
If (OldVal <> NewVal) Or Bereich Then _
Call SchreibSatz(FileNumber, _
Benutzername, _
c.Address, _
ZName, _
OldVal, _
NewVal, _
Bereich)
If Bereich Then varValue = ""
Next
Close #FileNumber
End Sub
Sub wscAP_SelectionChange(varValue, strAddress)
varValue = ActiveCell.Value
If ActiveCell.HasFormula Then _
varValue = CStr(ActiveCell.Formula)
strAddress = ActiveCell.Address
End Sub
Private Sub InitBereich()
Dim iniRng, c, FileNumber
Dim OldVal, Benutzername, ZName, dateiname As String
Set iniRng = ActiveSheet.Range("A1:Z1000")
Benutzername = syGetUserName
dateiname = Pfad & "XL_" & Format(Date, "yyyymmdd") & ".lgf"
FileNumber = FreeFile
Open dateiname For Append As #FileNumber
For Each c In iniRng
ZName = ""
On Error Resume Next
ZName = c.Name.Name
OldVal = CStr(c.Value)
If c.HasFormula Then OldVal = CStr(c.Formula)
If (OldVal <> "") Then _
Call SchreibSatz(FileNumber, _
Benutzername, _
c.Address, _
ZName, _
OldVal, _
"", _
"Init")
Next
Close #FileNumber
End Sub
Private Sub SchreibSatz(fn, bn, ca, zn, ov, nv, kz)
Dim Satz As String
Satz = ActiveWorkbook.FullName & "," & ActiveSheet.Name & "," _
& bn & "," & ca & "," & zn & "," & ov & "," & nv & "," _
& Format(Date, "dd.mm.yyyy") & "," _
& Format(Time, "hh:nn:ss") & "," _
& kz
Write #fn, Satz
End Sub
Private Sub ProtokollLesen()
Dim Zeile, Datum
Dim ws As Worksheet
Dim dateiname, VonDatum, BisDatum, Benutzer As String
Set ws = Worksheets("Tabelle2")
VonDatum = "10.05.2002"
BisDatum = "18.05.2002"
Benutzer = ""
ws.Cells.ClearContents
Zeile = Zeile + 1
For Datum = CDate(VonDatum) To CDate(BisDatum)
Call LiesEinenTag(ws, Datum, Benutzer, Zeile)
Next
End Sub
Private Sub LiesEinenTag(ws, Datum, Benutzer, Zeile)
Dim Satz, x, z, FileNumber
Dim arr() As String
Dim dateiname As String
Dim dt
Dim BenutzerAngabe As Boolean
FileNumber = FreeFile
dt = Format(Datum, "yyyymmdd")
dateiname = Pfad & "XL_" & dt & ".lgf"
On Error GoTo ende2
Open dateiname For Input As #FileNumber
BenutzerAngabe = (Benutzer <> "")
While Not EOF(FileNumber)
Input #FileNumber, Satz
arr = SplitString(Satz, ",")
If BenutzerAngabe And (arr(3) <> Benutzer) Then GoTo ende
For x = 1 To UBound(arr)
Set z = ws.Cells(Zeile, x)
z.Value = "'" & arr(x)
Next
Zeile = Zeile + 1
ende:
Wend
Close #FileNumber
ende2:
End Sub
Private Function SplitString(ByVal txt As String, strSeparator As String)
Dim arr() As String
Dim intCounter As Integer
Do
intCounter = intCounter + 1
ReDim Preserve arr(1 To intCounter)
If InStr(txt, strSeparator) Then
arr(intCounter) = Left(txt, InStr(txt, strSeparator) - 1)
txt = Right(txt, Len(txt) - InStr(txt, strSeparator))
Else
arr(intCounter) = txt
Exit Do
End If
Loop
SplitString = arr
End Function
Private Function syGetUserName() As String
Dim lpBuff As String * 25
Get_User_Name lpBuff, 25
syGetUserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
End Function