Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Protokollierung von Datenänderungen
zurück: In einer Spalte Zahlen ohne Doppler und Lücken einfügen weiter: alle leeren Zeilen im Blatt löschen Bereich von A1:L100 Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Antwort Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
rerraps
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Apr 2014, 14:43
Rufname:

Protokollierung von Datenänderungen - Protokollierung von Datenänderungen

Nach oben
       Version: Office 2010

Hallo,

habe einen Code zur Protokollierung von Änderungen in einer Arbeitsmappe komme aber nicht drauf das nicht die komplette Arbeitsmappe protokolliert wird sonder nur ein Sheet dieser Sheet heißt bei mir "Histroy" außerdem sollte wenn eine komplette Zeile aus der History gelöscht wird eine Kopie der geloschten Zeile in ein anderes verstecktes Tabellenblatt (z. B. Loeschungen) umgeleitet werden.

Hier mein bereits vorhandener Code

Option Explicit

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Dim Username As String

Private Sub Workbook_Open()
Dim Buffer As String * 100, BuffLen As Long
BuffLen = 100
GetUserName Buffer, BuffLen
Username = Left(Buffer, BuffLen)
Username = Left(Username, InStr(Username, vbNullChar) - 1)
If Trim$(Username) = "" Then Username = Application.Username
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim intSpalte As Integer, lngZeile As Long, strBuchstabe1 As String, strBuchstabe2 As String
Dim varArray_neu As Variant, varArray_alt As Variant, intArrayspalte As Integer, strAdresse As String
Dim lngArrayzeile As Long, lngLetzteZeile As Long, varAlt As Variant, varNeu As Variant
If Sh.Name <> "Protokoll" Then
If Target.Count > 1 Then varArray_neu = Range(Target.Address) Else varNeu = Target
strAdresse = Selection.Address
With Application
.ScreenUpdating = False
.EnableEvents = False
.Undo
End With
If Target.Count > 1 Then
varArray_alt = Range(Target.Address)
Application.Undo
With Worksheets("Protokoll")
For intSpalte = Target.Column To Target.Column + Target.Columns.Count - 1
intArrayspalte = intArrayspalte + 1
lngArrayzeile = 0
For lngZeile = Target.Row To Target.Row + Target.Rows.Count - 1
lngArrayzeile = lngArrayzeile + 1
If varArray_alt(lngArrayzeile, intArrayspalte) <> varArray_neu(lngArrayzeile, intArrayspalte) Then
lngLetzteZeile = .Cells(65536, 1).End(xlUp).Row + 1
If lngLetzteZeile = 65536 Then
lngLetzteZeile = 2
.Range("A2:E65536").ClearContents
End If
.Cells(lngLetzteZeile, 1) = Now
.Cells(lngLetzteZeile, 2) = varArray_alt(lngArrayzeile, intArrayspalte)
.Cells(lngLetzteZeile, 3) = varArray_neu(lngArrayzeile, intArrayspalte)
.Cells(lngLetzteZeile, 4) = Cells(lngZeile, intSpalte).Address(0, 0)
.Cells(lngLetzteZeile, 5) = Sh.Name
.Cells(lngLetzteZeile, 6) = VBA.Environ("Username")
End If
Next
Next
End With
Else
varAlt = Range(Target.Address)
Application.Undo
With Worksheets("Protokoll")
lngLetzteZeile = .Cells(65536, 1).End(xlUp).Row + 1
If lngLetzteZeile = 65536 Then
lngLetzteZeile = 2
.Range("A2:E65536").ClearContents
End If
.Cells(lngLetzteZeile, 1) = Now
.Cells(lngLetzteZeile, 2) = varAlt
.Cells(lngLetzteZeile, 3) = varNeu
.Cells(lngLetzteZeile, 4) = Target.Address(False, False)
.Cells(lngLetzteZeile, 5) = Sh.Name
.Cells(lngLetzteZeile, 6) = VBA.Environ("Username")
End With
End If
Range(strAdresse).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Areas.Count > 1 Then
MsgBox "Auswahl nicht zulässig.", 48, "Hinweis"
Application.EnableEvents = False
Range(Target.Address).Cells(1, 1).Select
Application.EnableEvents = True
End If
End Sub


Besten Dank schon mal für Eure hilfe.

Gruß rerraps
Crazy Tom
eigenen Code Nichtversteher


Verfasst am:
30. Apr 2014, 18:03
Rufname:
Wohnort: Bonn

AW: Protokollierung von Datenänderungen - AW: Protokollierung von Datenänderungen

Nach oben
       Version: Office 2010

Hallo Roman

in das Codemodul DieseArbeitsmappe

Code:
Option Explicit

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Dim Username As String

Private Sub Workbook_Open()
    Dim Buffer As String * 100, BuffLen As Long
    BuffLen = 100
    GetUserName Buffer, BuffLen
    Username = Left(Buffer, BuffLen)
    Username = Left(Username, InStr(Username, vbNullChar) - 1)
    If Trim$(Username) = "" Then Username = Application.Username
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Areas.Count > 1 Then
    MsgBox "Auswahl nicht zulässig.", 48, "Hinweis"
    Application.EnableEvents = False
    Range(Target.Address).Cells(1, 1).Select
    Application.EnableEvents = True
    End If
End Sub


und ins Codemodul deines Arbeitsblatts Histroy diesen Code

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim intSpalte As Integer, lngZeile As Long, strBuchstabe1 As String, strBuchstabe2 As String
    Dim varArray_neu As Variant, varArray_alt As Variant, intArrayspalte As Integer, strAdresse As String
    Dim lngArrayzeile As Long, lngLetzteZeile As Long, varAlt As Variant, varNeu As Variant
   
    If Target.Count > 1 Then varArray_neu = Range(Target.Address) Else varNeu = Target
    strAdresse = Selection.Address
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Undo
    End With
    If Target.Count > 1 Then
    varArray_alt = Range(Target.Address)
    Application.Undo
    With Worksheets("Protokoll")
    For intSpalte = Target.Column To Target.Column + Target.Columns.Count - 1
    intArrayspalte = intArrayspalte + 1
    lngArrayzeile = 0
    For lngZeile = Target.Row To Target.Row + Target.Rows.Count - 1
    lngArrayzeile = lngArrayzeile + 1
    If varArray_alt(lngArrayzeile, intArrayspalte) <> varArray_neu(lngArrayzeile, intArrayspalte) Then
    lngLetzteZeile = .Cells(65536, 1).End(xlUp).Row + 1
    If lngLetzteZeile = 65536 Then
    lngLetzteZeile = 2
    .Range("A2:E65536").ClearContents
    End If
    .Cells(lngLetzteZeile, 1) = Now
    .Cells(lngLetzteZeile, 2) = varArray_alt(lngArrayzeile, intArrayspalte)
    .Cells(lngLetzteZeile, 3) = varArray_neu(lngArrayzeile, intArrayspalte)
    .Cells(lngLetzteZeile, 4) = Cells(lngZeile, intSpalte).Address(0, 0)
    .Cells(lngLetzteZeile, 5) = ActiveSheet.Name
    .Cells(lngLetzteZeile, 6) = VBA.Environ("Username")
    End If
    Next
    Next
    End With
    Else
    varAlt = Range(Target.Address)
    Application.Undo
    With Worksheets("Protokoll")
    lngLetzteZeile = .Cells(65536, 1).End(xlUp).Row + 1
    If lngLetzteZeile = 65536 Then
    lngLetzteZeile = 2
    .Range("A2:E65536").ClearContents
    End If
    .Cells(lngLetzteZeile, 1) = Now
    .Cells(lngLetzteZeile, 2) = varAlt
    .Cells(lngLetzteZeile, 3) = varNeu
    .Cells(lngLetzteZeile, 4) = Target.Address(False, False)
    .Cells(lngLetzteZeile, 5) = ActiveSheet.Name
    .Cells(lngLetzteZeile, 6) = VBA.Environ("Username")
    End With
    End If
    Range(strAdresse).Select
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
End Sub

_________________
MfG Tom
Rückmeldung wäre nett
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 VBA (Makros): Rückgängig Button bei Protokollierung 2 VBA__Newbie 91 11. März 2013, 19:28
RPP63 Rückgängig Button bei Protokollierung
Keine neuen Beiträge Excel VBA (Makros): Protokollierung des Users 3 Gast 129 14. Nov 2011, 14:54
Gast Protokollierung des Users
Keine neuen Beiträge Excel VBA (Makros): Protokollierung von Änderungen bei Berechnungen 5 Geigip 246 21. Jan 2011, 20:57
Thomas Ramel Protokollierung von Änderungen bei Berechnungen
Keine neuen Beiträge Excel Hilfe: Undo Fehler Protokollierung 0 Gast 192 12. Jan 2011, 12:39
Gast Undo Fehler Protokollierung
Keine neuen Beiträge Excel VBA (Makros): Kommentarfeld / Protokollierung 5 Nenilix 210 16. Okt 2010, 15:51
Thomas Ramel Kommentarfeld / Protokollierung
Keine neuen Beiträge Excel VBA (Makros): Datenänderungen per Mail weitergeben 1 Tutti31 238 30. Nov 2009, 06:04
werni barny Datenänderungen per Mail weitergeben
Keine neuen Beiträge Excel VBA (Makros): Problem bei Protokollierung 5 *Jenny 181 16. Jul 2009, 15:57
*Jenny Problem bei Protokollierung
Keine neuen Beiträge Excel VBA (Makros): Protokollierung von Bereichen 1 stivie 275 13. Mai 2008, 08:14
stivie Protokollierung von Bereichen
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: HTML Editor Forum