Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Änderungen protokollieren
zurück: Bildschirmschoner und Energiesparmodus unterdrücken weiter: Dateieigenschaften lesen und schreiben Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Information Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Isabelle :-)
Menschin


Verfasst am:
15. Mai 2013, 10:05
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis


Änderungen protokollieren - Änderungen protokollieren

Nach oben
       Version: Office 2k (2000)

Hallöchen,

du willst wissen, wann wer was in einer Tabelle geändert hat?

Dafür habe ich mal eine Lösung gebastelt. Das Protokoll wird als CSV-Datei ausgegeben, das ist erheblich schneller, als es in der Mappe selbst zu führen und bläht die Mappe nicht unnötig auf. Die Datei wird für die meisten Nutzer unsichtbar bleiben, da ich diese als versteckte Systemdatei tarne. Du musst also zum öffnen und löschen des Protokolls, außer du machst das per Makro, in den Ordneroptionen einstellen, dass du sowohl versteckte, als auch Systemdateien angezeigt bekommst.

Davon habe ich drei Versionen.

Version 1: Alle Zellen in allen Tabellen werden überwacht. Obwohl der Code sehr schnell ist, Änderungen in den 65.536 Zellen einer Spalte der alten Excelversionen schafft es in 0,5 Sekunden, würde ich bei den neuen Excelversionen mit 1.048.576 Zeilen davon abraten, wenn es nicht unbedingt sein muss. Denn wenn da einer auf die Idee kommt eine komplette Spalte mit Werten zu füllen, dauert es rund 10 Sekunden um dies zu protokollieren. Zudem werden damit auf einen Schlag 1.048.577 Zeilen in die CSV-Datei geschrieben, was ein öffnen in Excel zwar nicht unmöglich macht, aber die letzte Zeile und darauf folgende können schon nicht mehr in Excel angezeigt werden. Dann hilft nur noch ein externes Programm wie der Text-Editor, oder eine spezielle VBA-Routine zum Import überlanger CSV-Dateien nach Excel, um sich das Protokoll ansehen zu können.

Version 2: Alle Zellen in bestimmten Tabellen werden Überwacht. Da ist im Prinzip nur zweimal eine Abfrage nach dem Objektnamen der aktiven Tabelle vorgeschaltet. Ansonsten habe ich da dieselben Bedenken wie bei der Version 1.

Version 3: Bestimmte Bereiche in bestimmten Tabellen werden überwacht. Diese Version dürfte für die meisten Ansprüche genügen, denn wer hat schon Tabellen in der alle Zeilen in allen Spalten genutzt werden. Ich würde da auch nicht komplette Spalten als zu überwachenden Bereich angeben, sondern mich an einem realistischen Datenvolumen plus einer gewissen Reserve orientieren. Sollte sich das Datenvolumen wider Erwarten rasant nach oben entwickeln, dann ist eine Anpassung der Bereiche kein großer Aufwand.

Achtung, ich kenne da die rechtliche Seite nicht. Aber der ungefragte Einsatz des Codes könnte deine fristlose Kündigung bewirken. Stimme das also vorher auf alle Fälle mit deinem Vorgesetzten ab und lass dir dessen Genehmigung schriftlich bestätigen. Wenn der dann Ärger mit dem Betriebsrat bekommt, bist du aus dem Schneider.

Der komplette Code muss in das Modul "DieseArbeitsmappe" !!!

Version 1:

Code:
Option Explicit

Private Declare Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Private Const LOGFILE_PATH = "D:\"
Private Const LOGFILE_NAME = "LogFile1.csv"
Private Const TEMP_PREFIX = "Temp_"

Private mavntValues As Variant
Private mintFileNumber As Integer
Private mstrUser As String
Private mblnInit As Boolean
Private mastrLogArrayMultiChange() As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    If Not Saved Then

        Select Case MsgBox("Sollen Ihre Änderungen in '" & Name & _
            "' gespeichert werden", vbExclamation Or vbYesNoCancel)

            Case vbYes

                'Logfile schliessen
                Call CloseLogfile

                'Speichern
                Save

            Case vbNo

                'Logfile schliessen
                Call CloseLogfile

                'Temporaeres Logfile zurueckkopieren
                Call CopyFileA(LOGFILE_PATH & TEMP_PREFIX & _
                    LOGFILE_NAME, LOGFILE_PATH & LOGFILE_NAME, 0&)

                'Gespeichert Flag setzen
                Saved = True

            Case vbCancel

                'Abbrechen Flag setzen
                Cancel = True

        End Select
    End If

    If Not Cancel Then

        'Temporaeres Logfile loeschen
        Call KillTempLogFile

    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Logfile schliessen
    Call CloseLogfile

    'Neue temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

    'Logfile wieder oeffnen
    Call OpenLogfile

End Sub

Private Sub Workbook_Open()

    'Variablen initialisieren
    Call InitLogFile

    'Temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Wenn das aktive Blatt eine Tabelle ist
    If TypeOf Sh Is Worksheet Then

        With Sh

            'Array mit den vorhandenen Werten fuellen
            mavntValues = .Range(.Cells(1, 1), .Cells( _
                .UsedRange.Rows.Count + .UsedRange.Row - 1, _
                .UsedRange.Columns.Count + .UsedRange.Column - 1)).Value

            'Wenn kein Array aus den Werten gebildet wird
            If Not IsArray(mavntValues) Then

                'Wenn nur in A1 ein Wert steht
                If Not IsEmpty(mavntValues) Then

                    'Array kuenstlich anlegen
                    ReDim mavntValues(1 To 1, 1 To 1)

                    'Wert in das Array schreiben.
                    mavntValues(1, 1) = .Cells(1, 1).Value

                End If
            End If
        End With
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim blnMultiChange As Boolean
    Dim lngColumn As Long, lngColumnOffset As Long
    Dim lngRow As Long, lngRowOffset As Long
    Dim lngRowNumber As Long, ialngIndex As Long
    Dim strColumnLetter As String, strSheetName As String
    Dim strDateTime As String
    Dim avntValues As Variant
    Dim objArea As Range

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Tabellenname holen
    strSheetName = Sh.Name

    'Datum und Uhrzeit der Aenderung
    strDateTime = CStr(Now)

    'Bereiche mit geaenderten Zellen einzeln durchlaufen
    For Each objArea In Target.Areas

        'Wenn mehr als eine Zelle geaendert wurde
        If objArea.Count > 1 Then

            'Flag setzen
            blnMultiChange = True

            'Array dimensionieren
            ReDim mastrLogArrayMultiChange(1 To objArea.Count)

            'Index fuer Array zuruecksetzen
            ialngIndex = 0

        End If

        'Geaenderte Werte holen
        avntValues = objArea.Value

        'Wenn nur ein einzelner Wert geaendert wurde
        If Not IsArray(avntValues) Then

            'Array fuer einen Wert erzeugen
            ReDim avntValues(1 To 1, 1 To 1)

            'Geaenderten Wert in das Array schreiben
            avntValues(1, 1) = objArea.Value

        End If

        'Versatz der Zeilen und Spalten gegen Zelle A1 berechnen
        lngRowOffset = objArea.Row - 1
        lngColumnOffset = objArea.Column - 1

        'Wenn die Tabelle nicht leer war
        If Not IsEmpty(mavntValues) Then

            'Schleife ueber die geaenderten Spalten
            For lngColumn = objArea.Column To objArea.Column + objArea.Columns.Count - 1

                'Spaltenbuchstabe holen
                strColumnLetter = Split(Sh.Cells(1, lngColumn).Address, "$")(1)

                'Erste Zeilennummer holen
                lngRowNumber = objArea.Row

                'Schleife ueber die geaenderten Zeilen
                For lngRow = objArea.Row To objArea.Row + objArea.Rows.Count - 1

                    'Wenn die geaenderte Zeile im bisher benutzen Bereich liegt
                    If lngRow <= UBound(mavntValues, 1) Then

                        'Wenn die geaenderte Spalte im bisher benutzen Bereich liegt
                        If lngColumn <= UBound(mavntValues, 2) Then

                            'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                            If mavntValues(lngRow, lngColumn) <> avntValues( _
                                lngRow - lngRowOffset, lngColumn - lngColumnOffset) Then

                                'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                                ialngIndex = ialngIndex + 1

                                'Logfile schreiben
                                Call WriteLog(strDateTime, mavntValues(lngRow, lngColumn), _
                                    avntValues(lngRow - lngRowOffset, lngColumn - lngColumnOffset), _
                                    strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                    blnMultiChange, ialngIndex, False)

                            End If
                        Else

                            'Spalte liegt nicht im bisher benutzen Bereich

                            'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                            If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                                lngColumn - lngColumnOffset)) Then

                                'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                                ialngIndex = ialngIndex + 1

                                'Logfile schreiben
                                Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                                    lngRowOffset, lngColumn - lngColumnOffset), _
                                    strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                    blnMultiChange, ialngIndex, False)

                            End If
                        End If
                    Else

                        'Zeile liegt nicht im bisher benutzen Bereich

                        'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                        If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                            lngColumn - lngColumnOffset)) Then

                            'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                            ialngIndex = ialngIndex + 1

                            'Logfile schreiben
                            Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                                lngRowOffset, lngColumn - lngColumnOffset), _
                                strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                blnMultiChange, ialngIndex, False)

                        End If
                    End If

                    'Zeilennummer hochzaehlen
                    lngRowNumber = lngRowNumber + 1

                Next
            Next
        Else

            'Tabelle war leer

            'Schleife ueber die geaenderten Spalten
            For lngColumn = objArea.Column To objArea.Column + objArea.Columns.Count - 1

                'Spaltenbuchstabe holen
                strColumnLetter = Split(Sh.Cells(1, lngColumn).Address, "$")(1)

                'Erste Zeilennummer holen
                lngRowNumber = objArea.Row

                'Schleife ueber die geaenderten Zeilen
                For lngRow = objArea.Row To objArea.Row + objArea.Rows.Count - 1

                    'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                    If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                        lngColumn - lngColumnOffset)) Then

                        'Index fuer Array wenn mehr als eine Zelle geaendert wurde
                        ialngIndex = ialngIndex + 1

                        'Logfile schreiben
                        Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                            lngRowOffset, lngColumn - lngColumnOffset), _
                            strColumnLetter & CStr(lngRowNumber), strSheetName, _
                            blnMultiChange, ialngIndex, False)

                    End If

                    'Zeilennummer hochzaehlen
                    lngRowNumber = lngRowNumber + 1

                Next
            Next
        End If

        'Wenn mehr als eine Zelle geaendert wurde
        If blnMultiChange Then Call WriteLog(vbNullString, Empty, Empty, _
            vbNullString, vbNullString, True, ialngIndex, True)

    Next

    'Array neu fuellen
    Call Workbook_SheetActivate(Sh)

    'Wenn unabhaengige Bereiche geaendert wurden muss der "Rueckgaengig machen"
    'Speicher geloescht werden da sonst das Protokoll nicht richtig geschrieben wird
    If Target.Areas.Count > 1 Then

        'Ereignisroutinen ausschalten
        Application.EnableEvents = False

        'Die oberste linke Zelle des geändeten Bereiches in sich selbst kopieren
        Call Target.Cells(1, 1).Copy(Destination:=Target.Cells(1, 1))

        'Ereignisroutinen einschalten
        Application.EnableEvents = True

    End If
End Sub

Private Sub OpenLogfile()
    Open LOGFILE_PATH & LOGFILE_NAME For Append As #mintFileNumber
End Sub

Private Sub CloseLogfile()
    Close #mintFileNumber
End Sub

Private Sub WriteLog( _
    ByRef prstrDateTime As String, _
    ByRef prvntOldValue As Variant, _
    ByRef prvntNewValue As Variant, _
    ByRef prstrAddress As String, _
    ByRef prstrSheetName As String, _
    ByRef prblnMultiChange As Boolean, _
    ByRef prialngIndex As Long, _
    ByRef prblnWriteMultiChangeArrayNow As Boolean)

    'Array der Logeintraege schreiben
    If prblnWriteMultiChangeArrayNow Then

        'Wenn ueberhaupt Eintraege geaendert wurden
        If prialngIndex > 0 Then

            'Array an die Anzahl der tatsaechlich geaenderten Eintraege anpassen
            ReDim Preserve mastrLogArrayMultiChange(1 To prialngIndex)

            'Array in CSV-Datei schreiben
            Print #mintFileNumber, Join(mastrLogArrayMultiChange, vbCrLf)

        End If
    Else

        'Wenn mehrere Zellen gleichzeitig geaendert wurden
        If prblnMultiChange Then

            'Logeintraege in ein Array schreiben
            mastrLogArrayMultiChange(prialngIndex) = prstrDateTime & ";" _
                & mstrUser & ";" & prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        Else

            'Logfile direkt in CSV-Datei schreiben
            Print #mintFileNumber, prstrDateTime & ";" & mstrUser & ";" & _
                prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        End If
    End If
End Sub

Private Sub KillTempLogFile()

    'Pruefen ob temporaeres Logfile existiert
    If Dir$(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, _
        vbHidden Or vbSystem) <> vbNullString Then

        'Dateiattribut auf "normal" setzen
        Call SetAttr(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, vbNormal)

        'Temporaeres Logfile loeschen
        Call Kill(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME)

    End If
End Sub

Private Sub InitLogFile()

    Dim blnNewLog As Boolean

    'Flag setzen
    mblnInit = True

    'Aufruf um Array zu fuellen
    Call Workbook_SheetActivate(ActiveSheet)

    'Alle Textdateien schliessen
    Reset

    'Freie Dateinummer holen
    mintFileNumber = FreeFile

    'Benutzername holen
    mstrUser = Environ$("USERNAME")

    'Pruefen ob Logfile existiert
    blnNewLog = Dir$(LOGFILE_PATH & LOGFILE_NAME, _
        vbHidden Or vbSystem) = vbNullString

    'Logfile oeffnen
    Call OpenLogfile

    'Bei neuem Logfile
    If blnNewLog Then

        'Ueberschriften setzen
        Print #mintFileNumber, "Datum und Uhrzeit;" & _
            "Benutzer;Tabelle;Zelle;alter Wert;neuer Wert"

        'Logfile schliessen
        Call CloseLogfile

        'als verstecke Systemdatei kennzeichnen
        Call SetAttr(LOGFILE_PATH & _
            LOGFILE_NAME, vbHidden Or vbSystem)

        'Logfile wieder oeffnen
        Call OpenLogfile

    End If
End Sub


Version 2:

Code:
Option Explicit

Private Declare Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Private Const LOGFILE_PATH = "D:\"
Private Const LOGFILE_NAME = "LogFile2.csv"
Private Const TEMP_PREFIX = "Temp_"

Private mavntValues As Variant
Private mintFileNumber As Integer
Private mstrUser As String
Private mblnInit As Boolean
Private mastrLogArrayMultiChange() As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    If Not Saved Then

        Select Case MsgBox("Sollen Ihre Änderungen in '" & Name & _
            "' gespeichert werden", vbExclamation Or vbYesNoCancel)

            Case vbYes

                'Logfile schliessen
                Call CloseLogfile

                'Speichern
                Save

            Case vbNo

                'Logfile schliessen
                Call CloseLogfile

                'Temporaeres Logfile zurueckkopieren
                Call CopyFileA(LOGFILE_PATH & TEMP_PREFIX & _
                    LOGFILE_NAME, LOGFILE_PATH & LOGFILE_NAME, 0&)

                'Gespeichert Flag setzen
                Saved = True

            Case vbCancel

                'Abbrechen Flag setzen
                Cancel = True

        End Select
    End If

    If Not Cancel Then

        'Temporaeres Logfile loeschen
        Call KillTempLogFile

    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Logfile schliessen
    Call CloseLogfile

    'Neue temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

    'Logfile wieder oeffnen
    Call OpenLogfile

End Sub

Private Sub Workbook_Open()

    'Variablen initialisieren
    Call InitLogFile

    'Temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Wenn das aktive Blatt eine Tabelle ist
    If TypeOf Sh Is Worksheet Then

        With Sh

            Select Case .CodeName

                'Nur Tabellen mit diesen Objektnamen ueberwachen
                Case "Tabelle1", "Tabelle2"

                    'Array mit den vorhandenen Werten fuellen
                    mavntValues = .Range(.Cells(1, 1), .Cells( _
                        .UsedRange.Rows.Count + .UsedRange.Row - 1, _
                        .UsedRange.Columns.Count + .UsedRange.Column - 1)).Value

                    'Wenn kein Array aus den Werten gebildet wird
                    If Not IsArray(mavntValues) Then

                        'Wenn nur in A1 ein Wert steht
                        If Not IsEmpty(mavntValues) Then

                            'Array kuenstlich anlegen
                            ReDim mavntValues(1 To 1, 1 To 1)

                            'Wert in das Array schreiben.
                            mavntValues(1, 1) = .Cells(1, 1).Value

                        End If
                    End If
            End Select
        End With
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim blnMultiChange As Boolean
    Dim lngColumn As Long, lngColumnOffset As Long
    Dim lngRow As Long, lngRowOffset As Long
    Dim lngRowNumber As Long, ialngIndex As Long
    Dim strColumnLetter As String, strSheetName As String
    Dim strDateTime As String
    Dim avntValues As Variant
    Dim objArea As Range

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    Select Case Sh.CodeName

        'Nur Tabellen mit diesen Objektnamen ueberwachen
        Case "Tabelle1", "Tabelle2"

            'Tabellenname holen
            strSheetName = Sh.Name

            'Datum und Uhrzeit der Aenderung
            strDateTime = CStr(Now)

            'Bereiche mit geaenderten Zellen einzeln durchlaufen
            For Each objArea In Target.Areas

                'Wenn mehr als eine Zelle geaendert wurde
                If objArea.Count > 1 Then

                    'Flag setzen
                    blnMultiChange = True

                    'Array dimensionieren
                    ReDim mastrLogArrayMultiChange(1 To objArea.Count)

                    'Index fuer Array setzen
                    ialngIndex = 0

                End If

                'Geaenderte Werte holen
                avntValues = objArea.Value

                'Wenn nur ein einzelner Wert geaendert wurde
                If Not IsArray(avntValues) Then

                    'Array fuer einen Wert erzeugen
                    ReDim avntValues(1 To 1, 1 To 1)

                    'Geaenderten Wert in das Array schreiben
                    avntValues(1, 1) = objArea.Value

                End If

                'Versatz der Zeilen und Spalten gegen Zelle A1 berechnen
                lngRowOffset = objArea.Row - 1
                lngColumnOffset = objArea.Column - 1

                'Wenn die Tabelle nicht leer war
                If Not IsEmpty(mavntValues) Then

                    'Schleife ueber die geaenderten Spalten
                    For lngColumn = objArea.Column To objArea.Column + objArea.Columns.Count - 1

                        'Spaltenbuchstabe holen
                        strColumnLetter = Split(Sh.Cells(1, lngColumn).Address, "$")(1)

                        'Erste Zeilennummer holen
                        lngRowNumber = objArea.Row

                        'Schleife ueber die geaenderten Zeilen
                        For lngRow = objArea.Row To objArea.Row + objArea.Rows.Count - 1

                            'Wenn die geaenderte Zeile im bisher benutzen Bereich liegt
                            If lngRow <= UBound(mavntValues, 1) Then

                                'Wenn die geaenderte Spalte im bisher benutzen Bereich liegt
                                If lngColumn <= UBound(mavntValues, 2) Then

                                    'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                                    If mavntValues(lngRow, lngColumn) <> avntValues( _
                                        lngRow - lngRowOffset, lngColumn - lngColumnOffset) Then

                                        'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                                        ialngIndex = ialngIndex + 1

                                        'Logfile schreiben
                                        Call WriteLog(strDateTime, mavntValues(lngRow, lngColumn), _
                                            avntValues(lngRow - lngRowOffset, lngColumn - lngColumnOffset), _
                                            strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                            blnMultiChange, ialngIndex, False)

                                    End If
                                Else

                                    'Spalte liegt nicht im bisher benutzen Bereich

                                    'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                                    If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                                        lngColumn - lngColumnOffset)) Then

                                        'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                                        ialngIndex = ialngIndex + 1

                                        'Logfile schreiben
                                        Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                                            lngRowOffset, lngColumn - lngColumnOffset), _
                                            strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                            blnMultiChange, ialngIndex, False)

                                    End If
                                End If
                            Else

                                'Zeile liegt nicht im bisher benutzen Bereich

                                'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                                If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                                    lngColumn - lngColumnOffset)) Then

                                    'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                                    ialngIndex = ialngIndex + 1

                                    'Logfile schreiben
                                    Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                                        lngRowOffset, lngColumn - lngColumnOffset), _
                                        strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                        blnMultiChange, ialngIndex, False)

                                End If
                            End If

                            'Zeilennummer hochzaehlen
                            lngRowNumber = lngRowNumber + 1

                        Next
                    Next
                Else

                    'Tabelle war leer

                    'Schleife ueber die geaenderten Spalten
                    For lngColumn = objArea.Column To objArea.Column + objArea.Columns.Count - 1

                        'Spaltenbuchstabe holen
                        strColumnLetter = Split(Sh.Cells(1, lngColumn).Address, "$")(1)

                        'Erste Zeilennummer holen
                        lngRowNumber = objArea.Row

                        'Schleife ueber die geaenderten Zeilen
                        For lngRow = objArea.Row To objArea.Row + objArea.Rows.Count - 1

                            'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                            If Not IsEmpty(avntValues(lngRow - lngRowOffset, _
                                lngColumn - lngColumnOffset)) Then

                                'Index fuer Array wenn mehr als eine Zelle geaendert wurde
                                ialngIndex = ialngIndex + 1

                                'Logfile schreiben
                                Call WriteLog(strDateTime, Empty, avntValues(lngRow - _
                                    lngRowOffset, lngColumn - lngColumnOffset), _
                                    strColumnLetter & CStr(lngRowNumber), strSheetName, _
                                    blnMultiChange, ialngIndex, False)

                            End If

                            'Zeilennummer hochzaehlen
                            lngRowNumber = lngRowNumber + 1

                        Next
                    Next
                End If

                'Wenn mehr als eine Zelle geaendert wurde
                If blnMultiChange Then Call WriteLog(vbNullString, Empty, Empty, _
                    vbNullString, vbNullString, True, ialngIndex, True)

            Next

            'Array neu fuellen
            Call Workbook_SheetActivate(Sh)

            'Wenn unabhaengige Bereiche geaendert wurden muss der "Rueckgaengig machen"
            'Speicher geloescht werden da sonst das Protokoll nicht richtig geschrieben wird
            If Target.Areas.Count > 1 Then

                'Ereignisroutinen ausschalten
                Application.EnableEvents = False

                'Die oberste linke Zelle des geändeten Bereiches in sich selbst kopieren
                Call Target.Cells(1, 1).Copy(Destination:=Target.Cells(1, 1))

                'Ereignisroutinen einschalten
                Application.EnableEvents = True

            End If
    End Select
End Sub

Private Sub OpenLogfile()
    Open LOGFILE_PATH & LOGFILE_NAME For Append As #mintFileNumber
End Sub

Private Sub CloseLogfile()
    Close #mintFileNumber
End Sub

Private Sub WriteLog( _
    ByRef prstrDateTime As String, _
    ByRef prvntOldValue As Variant, _
    ByRef prvntNewValue As Variant, _
    ByRef prstrAddress As String, _
    ByRef prstrSheetName As String, _
    ByRef prblnMultiChange As Boolean, _
    ByRef prialngIndex As Long, _
    ByRef prblnWriteMultiChangeArrayNow As Boolean)

    'Array der Logeintraege schreiben
    If prblnWriteMultiChangeArrayNow Then

        'Wenn ueberhaupt Eintraege geaendert wurden
        If prialngIndex > 0 Then

            'Array an die Anzahl der tatsaechlich geaenderten Eintraege anpassen
            ReDim Preserve mastrLogArrayMultiChange(1 To prialngIndex)

            'Array in CSV-Datei schreiben
            Print #mintFileNumber, Join(mastrLogArrayMultiChange, vbCrLf)

        End If
    Else

        'Wenn mehrere Zellen gleichzeitig geaendert wurden
        If prblnMultiChange Then

            'Logeintraege in ein Array schreiben
            mastrLogArrayMultiChange(prialngIndex) = prstrDateTime & ";" _
                & mstrUser & ";" & prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        Else

            'Logfile direkt in CSV-Datei schreiben
            Print #mintFileNumber, prstrDateTime & ";" & mstrUser & ";" & _
                prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        End If
    End If
End Sub

Private Sub KillTempLogFile()

    'Pruefen ob temporaeres Logfile existiert
    If Dir$(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, _
        vbHidden Or vbSystem) <> vbNullString Then

        'Dateiattribut auf "normal" setzen
        Call SetAttr(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, vbNormal)

        'Temporaeres Logfile loeschen
        Call Kill(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME)

    End If
End Sub

Private Sub InitLogFile()

    Dim blnNewLog As Boolean

    'Flag setzen
    mblnInit = True

    'Aufruf um Array zu fuellen
    Call Workbook_SheetActivate(ActiveSheet)

    'Alle Textdateien schliessen
    Reset

    'Freie Dateinummer holen
    mintFileNumber = FreeFile

    'Benutzername holen
    mstrUser = Environ$("USERNAME")

    'Pruefen ob Logfile existiert
    blnNewLog = Dir$(LOGFILE_PATH & LOGFILE_NAME, _
        vbHidden Or vbSystem) = vbNullString

    'Logfile oeffnen
    Call OpenLogfile

    'Bei neuem Logfile
    If blnNewLog Then

        'Ueberschriften setzen
        Print #mintFileNumber, "Datum und Uhrzeit;" & _
            "Benutzer;Tabelle;Zelle;alter Wert;neuer Wert"

        'Logfile schliessen
        Call CloseLogfile

        'als verstecke Systemdatei kennzeichnen
        Call SetAttr(LOGFILE_PATH & _
            LOGFILE_NAME, vbHidden Or vbSystem)

        'Logfile wieder oeffnen
        Call OpenLogfile

    End If
End Sub


Version 3:

Code:
Option Explicit

Private Declare Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Private Const LOGFILE_PATH = "D:\"
Private Const LOGFILE_NAME = "LogFile3.csv"
Private Const TEMP_PREFIX = "Temp_"

Private mavntValues As Variant
Private mintFileNumber As Integer
Private mstrUser As String
Private mblnInit As Boolean
Private mastrLogArrayMultiChange() As String
Private mstrMonitoringRange As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    If Not Saved Then

        Select Case MsgBox("Sollen Ihre Änderungen in '" & Name & _
            "' gespeichert werden", vbExclamation Or vbYesNoCancel)

            Case vbYes

                'Logfile schliessen
                Call CloseLogfile

                'Speichern
                Save

            Case vbNo

                'Logfile schliessen
                Call CloseLogfile

                'Temporaeres Logfile zurueckkopieren
                Call CopyFileA(LOGFILE_PATH & TEMP_PREFIX & _
                    LOGFILE_NAME, LOGFILE_PATH & LOGFILE_NAME, 0&)

                'Gespeichert Flag setzen
                Saved = True

            Case vbCancel

                'Abbrechen Flag setzen
                Cancel = True

        End Select
    End If

    If Not Cancel Then

        'Temporaeres Logfile loeschen
        Call KillTempLogFile

    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Logfile schliessen
    Call CloseLogfile

    'Neue temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

    'Logfile wieder oeffnen
    Call OpenLogfile

End Sub

Private Sub Workbook_Open()

    'Variablen initialisieren
    Call InitLogFile

    'Temporaere Kopie des Logfiles erstellen
    Call CopyFileA(LOGFILE_PATH & LOGFILE_NAME, _
        LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, 0&)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Wenn das aktive Blatt eine Tabelle ist
    If TypeOf Sh Is Worksheet Then

        With Sh

            Select Case .CodeName

                Case "Tabelle1"

                    'Ueberwachter Bereich
                    mstrMonitoringRange = "A1:A100"

                    'Array mit den vorhandenen Werten fuellen
                    mavntValues = .Range(mstrMonitoringRange)

                Case "Tabelle2"

                    'Ueberwachter Bereich
                    mstrMonitoringRange = "C3:F501"

                    'Array mit den vorhandenen Werten fuellen
                    mavntValues = .Range(mstrMonitoringRange)

                Case Else

                    'Kein ueberwachter Bereich
                    mstrMonitoringRange = vbNullString

                    'Array leeren
                    mavntValues = Empty

            End Select
        End With
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim blnMultiChange As Boolean
    Dim lngColumn As Long, lngColumnOffset As Long
    Dim lngRow As Long, lngRowOffset As Long
    Dim lngRowNumber As Long, ialngIndex As Long
    Dim strColumnLetter As String, strSheetName As String
    Dim strDateTime As String
    Dim avntValues As Variant
    Dim objRange As Range, objArea As Range

    'Pruefen ob Variablen initialisiert sind
    If Not mblnInit Then Call InitLogFile

    'Wenn die Tabelle ueberwacht wird
    If mstrMonitoringRange <> vbNullString Then

        'Ueberwachten Bereich aus geaenderten Bereich extrahieren
        Set objRange = Intersect(Target, Sh.Range(mstrMonitoringRange))

        'Wenn Aenderung im ueberwachten Bereich
        If Not objRange Is Nothing Then

            'Tabellenname holen
            strSheetName = Sh.Name

            'Datum und Uhrzeit der Aenderung
            strDateTime = CStr(Now)

            'Bereiche mit geaenderten Zellen einzeln durchlaufen
            For Each objArea In objRange.Areas

                'Versatz der Zeilen und Spalten gegen erste Zelle des ueberwachten Bereichs berechnen
                lngRowOffset = objArea.Row - Sh.Range(mstrMonitoringRange).Row
                lngColumnOffset = objArea.Column - Sh.Range(mstrMonitoringRange).Column

                'Wenn mehr als eine Zelle geaendert wurde
                If objArea.Count > 1 Then

                    'Flag setzen
                    blnMultiChange = True

                    'Array dimensionieren
                    ReDim mastrLogArrayMultiChange(1 To objArea.Count)

                    'Index fuer Array setzen
                    ialngIndex = 0

                End If

                'Geaenderte Werte holen
                avntValues = objArea.Value

                'Wenn nur ein einzelner Wert geaendert wurde
                If Not IsArray(avntValues) Then

                    'Array fuer einen Wert erzeugen
                    ReDim avntValues(1 To 1, 1 To 1)

                    'Geaenderten Wert in das Array schreiben
                    avntValues(1, 1) = objArea.Value

                End If

                'Schleife ueber die geaenderten Spalten
                For lngColumn = 1 To UBound(avntValues, 2)

                    'Spaltenbuchstabe holen
                    strColumnLetter = Split(Sh.Cells(1, lngColumn + _
                        objArea.Column - 1).Address, "$")(1)

                    'Erste Zeilennummer holen
                    lngRowNumber = objArea.Row

                    'Schleife ueber die geaenderten Zeilen
                    For lngRow = 1 To UBound(avntValues, 1)

                        'Pruefen ob tatsaechlich ein neuer Wert eingetragen wurde
                        If mavntValues(lngRow + lngRowOffset, lngColumn + _
                            lngColumnOffset) <> avntValues(lngRow, lngColumn) Then

                            'Index fuer Array wenn mehr als eine Zelle geaendert wurde hochzaehlen
                            ialngIndex = ialngIndex + 1

                            'Logfile schreiben
                            Call WriteLog(strDateTime, mavntValues(lngRow + _
                                lngRowOffset, lngColumn + lngColumnOffset), _
                                avntValues(lngRow, lngColumn), strColumnLetter & _
                                CStr(lngRowNumber), strSheetName, blnMultiChange, _
                                ialngIndex, False)

                            'Zeilennummer hochzaehlen
                            lngRowNumber = lngRowNumber + 1

                        End If
                    Next
                Next

                'Wenn mehr als eine Zelle geaendert wurde
                If blnMultiChange Then Call WriteLog(vbNullString, Empty, Empty, _
                    vbNullString, vbNullString, True, ialngIndex, True)

            Next

            'Array neu fuellen
            Call Workbook_SheetActivate(Sh)

            'Wenn unabhaengige Bereiche geaendert wurden muss der "Rueckgaengig machen"
            'Speicher geloescht werden da sonst das Protokoll nicht richtig geschrieben wird
            If Target.Areas.Count > 1 Then

                'Ereignisroutinen ausschalten
                Application.EnableEvents = False

                'Die oberste linke Zelle des geändeten Bereiches in sich selbst kopieren
                Call Target.Cells(1, 1).Copy(Destination:=Target.Cells(1, 1))

                'Ereignisroutinen einschalten
                Application.EnableEvents = True

            End If
        End If
    End If
End Sub

Private Sub OpenLogfile()
    Open LOGFILE_PATH & LOGFILE_NAME For Append As #mintFileNumber
End Sub

Private Sub CloseLogfile()
    Close #mintFileNumber
End Sub

Private Sub WriteLog( _
    ByRef prstrDateTime As String, _
    ByRef prvntOldValue As Variant, _
    ByRef prvntNewValue As Variant, _
    ByRef prstrAddress As String, _
    ByRef prstrSheetName As String, _
    ByRef prblnMultiChange As Boolean, _
    ByRef prialngIndex As Long, _
    ByRef prblnWriteMultiChangeArrayNow As Boolean)

    'Array der Logeintraege schreiben
    If prblnWriteMultiChangeArrayNow Then

        'Wenn ueberhaupt Eintraege geaendert wurden
        If prialngIndex > 0 Then

            'Array an die Anzahl der tatsaechlich geaenderten Eintraege anpassen
            ReDim Preserve mastrLogArrayMultiChange(1 To prialngIndex)

            'Array in CSV-Datei schreiben
            Print #mintFileNumber, Join(mastrLogArrayMultiChange, vbCrLf)

        End If
    Else

        'Wenn mehrere Zellen gleichzeitig geaendert wurden
        If prblnMultiChange Then

            'Logeintraege in ein Array schreiben
            mastrLogArrayMultiChange(prialngIndex) = prstrDateTime & ";" _
                & mstrUser & ";" & prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        Else

            'Logfile direkt in CSV-Datei schreiben
            Print #mintFileNumber, prstrDateTime & ";" & mstrUser & ";" & _
                prstrSheetName & ";" & prstrAddress & ";" & _
                CStr(prvntOldValue) & ";" & CStr(prvntNewValue)

        End If
    End If
End Sub

Private Sub KillTempLogFile()

    'Pruefen ob temporaeres Logfile existiert
    If Dir$(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, _
        vbHidden Or vbSystem) <> vbNullString Then

        'Dateiattribut auf "normal" setzen
        Call SetAttr(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME, vbNormal)

        'Temporaeres Logfile loeschen
        Call Kill(LOGFILE_PATH & TEMP_PREFIX & LOGFILE_NAME)

    End If
End Sub

Private Sub InitLogFile()

    Dim blnNewLog As Boolean

    'Flag setzen
    mblnInit = True

    'Aufruf um Array zu fuellen
    Call Workbook_SheetActivate(ActiveSheet)

    'Alle Textdateien schliessen
    Reset

    'Freie Dateinummer holen
    mintFileNumber = FreeFile

    'Benutzername holen
    mstrUser = Environ$("USERNAME")

    'Pruefen ob Logfile existiert
    blnNewLog = Dir$(LOGFILE_PATH & LOGFILE_NAME, _
        vbHidden Or vbSystem) = vbNullString

    'Logfile oeffnen
    Call OpenLogfile

    'Bei neuem Logfile
    If blnNewLog Then

        'Ueberschriften setzen
        Print #mintFileNumber, "Datum und Uhrzeit;" & _
            "Benutzer;Tabelle;Zelle;alter Wert;neuer Wert"

        'Logfile schliessen
        Call CloseLogfile

        'als verstecke Systemdatei kennzeichnen
        Call SetAttr(LOGFILE_PATH & _
            LOGFILE_NAME, vbHidden Or vbSystem)

        'Logfile wieder oeffnen
        Call OpenLogfile

    End If
End Sub

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Zeilen Vergleich und Änderungen anzeigen 0 mel kath 96 07. Mai 2013, 14:23
mel kath Zeilen Vergleich und Änderungen anzeigen
Keine neuen Beiträge Excel Formeln: 2 Tabellen vergleichen und bestimmte Änderungen anzeigen 2 brs2305 594 20. März 2012, 19:14
Gast 2 Tabellen vergleichen und bestimmte Änderungen anzeigen
Keine neuen Beiträge Excel VBA (Makros): Fehler in Änderungen protokollieren?? Code von Nepumuk 9 Mortgagor 384 11. Dez 2009, 15:46
kjot259 Fehler in Änderungen protokollieren?? Code von Nepumuk
Keine neuen Beiträge Excel VBA (Makros): Änderungen dokumentieren 2 *Jenny 616 05. Okt 2009, 08:08
*Jenny Änderungen dokumentieren
Keine neuen Beiträge Excel VBA (Makros): Änderungen verfolgen und kopieren 14 Ruedigermunz 1188 18. Aug 2009, 16:42
Ruedigermunz Änderungen verfolgen und kopieren
Keine neuen Beiträge Excel VBA (Makros): Datum anzeigen falls Änderungen in Zeile vorgenommen wurden 5 Rosalie 1522 30. Jul 2009, 15:18
faryon Datum anzeigen falls Änderungen in Zeile vorgenommen wurden
Keine neuen Beiträge Excel Formeln: Änderungen für alle Tabellenblätter übernehmen 11 Pionier 5613 14. Jul 2009, 12:42
Gast Änderungen für alle Tabellenblätter übernehmen
Keine neuen Beiträge Excel Formeln: Änderungen anzeigen - Bedingte Formatierung 6 Gast 800 17. Jun 2009, 10:00
Gast Änderungen anzeigen - Bedingte Formatierung
Keine neuen Beiträge Excel VBA (Makros): Daten gegenüberstellen prüfen auswerten - Änderungen ausgebe 4 Rennefuss 1111 27. Mai 2009, 12:54
Rennefuss Daten gegenüberstellen prüfen auswerten - Änderungen ausgebe
Keine neuen Beiträge Excel Formeln: Änderungen in Zahlenreihe erkennen! 1 mellowman 789 22. Apr 2009, 14:43
Janni 07 Änderungen in Zahlenreihe erkennen!
Keine neuen Beiträge Excel VBA (Makros): VBA Änderungen gehen trotz Speichern verloren 8 unruhe 1010 04. Jul 2008, 15:00
unruhe VBA Änderungen gehen trotz Speichern verloren
Keine neuen Beiträge Excel VBA (Makros): Problem: Änderungen in 2 Tabellen übernehmen 0 gungor 287 28. Apr 2008, 11:23
gungor Problem: Änderungen in 2 Tabellen übernehmen
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft Project