Markierung durch VBA Code nach Speichern löschen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Sheets("Tabelle1").Range("a:xfd").Interior.ColorIndex = xlNone End Sub

' ********************************************************************** ' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim lngIndex As Long, objSht As Worksheet If (0 / 1) + (Not Not pvarChange) <> 0 Then For lngIndex = 0 To UBound(pvarChange) Set objSht = getSheetByCodename(Split(pvarChange(lngIndex), "|")(0)) With objSht.Range(Split(pvarChange(lngIndex), "|")(1)).Interior If Clng(Split(pvarChange(lngIndex), "|")(2)) < 16777215 Then .Color = Clng(Split(pvarChange(lngIndex), "|")(2)) Else .Color = xlNone End If End With Set objSht = Nothing Next End If End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim rng As Range Select Case Sh.Name Case "Tabelle1", "Tablle3" 'Tabellen auf denen geprüft wird If Not Intersect(Target, Range("A:XFD")) Is Nothing Then For Each rng In Target If (0 / 1) + (Not Not pvarChange) = 0 Then Redim pvarChange(0) Else Redim Preserve pvarChange(UBound(pvarChange) + 1) End If pvarChange(UBound(pvarChange)) = Sh.CodeName & "|" & rng.Address(0, 0) & "|" & rng.Interior.Color rng.Interior.ColorIndex = 3 Next End If Case Else End Select End Sub ' ********************************************************************** ' Modul: basMain Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Public pvarChange() As Variant Public Function getSheetByCodename(ByVal strvCodeName As String, Optional ByRef wkbrWorkBook As Workbook) As Object Dim objSheet As Object On Error GoTo ERRORHANDLER If wkbrWorkBook Is Nothing Then Set wkbrWorkBook = ThisWorkbook For Each objSheet In wkbrWorkBook.Sheets If objSheet.CodeName = strvCodeName Then Set getSheetByCodename = objSheet Set objSheet = Nothing Exit Function End If Next ERRORHANDLER: Set getSheetByCodename = Nothing End Function

Hallo Stefanie,
hier eine bessere und universellere Version.

' **********************************************************************
' Modul: DieseArbeitsmappe  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lngIndex As Long, objSht As Worksheet

If colChanges.Count > 0 Then
  For lngIndex = 1 To colChanges.Count
    Set objSht = getSheetByCodename(colChanges(lngIndex).SheetCodeName)
    If Not objSht Is Nothing Then
      With objSht.Range(colChanges(lngIndex).CellAddress)
        .Interior.Color = colChanges(lngIndex).CellInteriorColor
        .Font.Color = colChanges(lngIndex).CellFontColor
      End With
      Set objSht = Nothing
    End If
  Next
  Set colChanges = Nothing
End If

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng As Range, clsItem As clsCollection

Select Case Sh.Name
  Case "Tabelle1", "Tabelle2" 'Tabellen auf denen geprüft wird
    'Zellbereich einschränken
    If Not Intersect(Target, Range("A:XFD")) Is Nothing Then
      For Each rng In Target
        If Not KeyExists(colChanges, rng.Parent.CodeName & rng.Address(0, 0)) Then
          Set clsItem = New clsCollection
          With clsItem
            .SheetCodeName = rng.Parent.CodeName
            .CellAddress = rng.Address(0, 0)
            .CellInteriorColor = rng.Interior.Color
            .CellFontColor = rng.Font.Color
          End With
          colChanges.Add clsItem, rng.Parent.CodeName & rng.Address(0, 0)
          Set clsItem = Nothing
        End If
        'geänderte Zellen kennzeichnen
        rng.Interior.Color = vbRed
        rng.Font.Color = vbYellow
      Next
    End If
  Case Else
End Select
End Sub

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public colChanges As New Collection

Public Function KeyExists(coll As Collection, Key As String) As Boolean
On Error GoTo ErrExit
coll.Item Key
KeyExists = True
ErrExit:
End Function

Public Function getSheetByCodename(ByVal strvCodeName As String, Optional ByRef wkbrWorkBook As Workbook) As Object
Dim objSheet As Object
On Error GoTo ERRORHANDLER
If wkbrWorkBook Is Nothing Then Set wkbrWorkBook = ThisWorkbook
For Each objSheet In wkbrWorkBook.Sheets
  If objSheet.CodeName = strvCodeName Then
    Set getSheetByCodename = objSheet
    Set objSheet = Nothing
    Exit Function
  End If
Next
ERRORHANDLER:
Set getSheetByCodename = Nothing
End Function

' **********************************************************************
' Modul: clsCollection  Typ: Klassenmodul
' **********************************************************************

Option Explicit

Private pstrCodename As String
Private pstrAddress As String
Private plngInteriorColor As Long
Private plngFontColor As Long


Public Property Get SheetCodeName() As String
SheetCodeName = pstrCodename
End Property

Public Property Let SheetCodeName(value As String)
pstrCodename = value
End Property

Public Property Get CellAddress() As String
CellAddress = pstrAddress
End Property

Public Property Let CellAddress(value As String)
pstrAddress = value
End Property

Public Property Get CellInteriorColor() As Long
If plngInteriorColor < 16777215 Then
  CellInteriorColor = plngInteriorColor
Else
  CellInteriorColor = -4142
End If
End Property

Public Property Let CellInteriorColor(value As Long)
plngInteriorColor = value
End Property

Public Property Get CellFontColor() As Long
CellFontColor = plngFontColor
End Property

Public Property Let CellFontColor(value As Long)
plngFontColor = value
End Property

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Markierung durch VBA Code nach Speichern löschen?

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Markierung durch VBA Code nach Speichern löschen?

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread