Thema Datum  Von Nutzer Rating
Antwort
24.04.2015 11:18:43 Seddi
NotSolved
24.04.2015 12:46:15 Gast62482
NotSolved
24.04.2015 13:04:38 Gast46398
NotSolved
24.04.2015 22:09:56 Gast49987
NotSolved
Rot Calculate ...Eine Änderung erkennen
26.04.2015 18:28:28 Gast33454
NotSolved
29.04.2015 07:20:37 Seddi
NotSolved
29.04.2015 07:35:00 Seddi
NotSolved

Ansicht des Beitrags:
Von:
Gast33454
Datum:
26.04.2015 18:28:28
Views:
1323
Rating: Antwort:
  Ja
Thema:
Calculate ...Eine Änderung erkennen

hm...

als Krücke wäre ggf. ein Vergleich zweier Datentabellen möglich

also...

abgestimmt auf Spalte C in Tabelle Test erhält diese Arbeitsmappe

z.B. ein eigenes Klassenmodul: clsExcelApp

'******************************************************************************
' Klassenmodul: clsExcelApp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'------------------------------------------------------------------------------
' beachte
'*************************************************** diesen Code in Worksheets_Open()
'Option Explicit
'Dim oKlasseExcel As clsExcelApp
'Private Sub Workbook_Open()
'    Set oKlasseExcel = New clsExcelApp
'    Set oKlasseExcel.ExcelWatch = Application
'End Sub
'************************************************************************************
'
Option Explicit
Public WithEvents ExcelWatch As Application
Dim oldArr() As Variant, newArr() As Variant

Private Sub ExcelWatch_SheetCalculate(ByVal Sh As Object)
Dim hit As Long
   Select Case Sh.Parent.Name
      Case ThisWorkbook.Name
         Select Case Sh.Name
            Case "Test"
               newArr = MakeArr()
               hit = ChkArrs()
               If hit <> 0 Then _
                  Call MsgBox("C" & Format(hit, "#0"), vbInformation, "Änderung")
               oldArr = newArr
            End Select
   End Select
End Sub

Private Sub ExcelWatch_WorkbookActivate(ByVal Wb As Workbook)
    Select Case Wb.Name
      Case ThisWorkbook.Name
         newArr = MakeArr(): oldArr = newArr
    End Select
End Sub

Private Function MakeArr() As Variant
Dim RngQ As Range, c As Range
On Error GoTo flaw
With Sheets("Test")
   Set c = Columns(3)
   Set RngQ = Range(c.Cells(1), c.Cells(c.Cells.Count).End(xlUp))
   MakeArr = RngQ
End With
flaw:
On Error GoTo 0
End Function

Private Function ChkArrs() As Long
Dim x As Long
On Error GoTo flaw
For x = LBound(newArr, 1) To UBound(newArr, 1)
   If newArr(x, 1) <> oldArr(x, 1) Then
      ChkArrs = x: Exit For
   End If
Next x
flaw:
On Error GoTo 0
End Function

 

und die Klasse Arbeitsmappe ein Open Ereignis

Option Explicit
Dim oKlasseExcel As clsExcelApp

Private Sub Workbook_Open()
Set oKlasseExcel = New clsExcelApp
Set oKlasseExcel.ExcelWatch = Application
End Sub

 

bleibt aber nur eine Krücke!


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
24.04.2015 11:18:43 Seddi
NotSolved
24.04.2015 12:46:15 Gast62482
NotSolved
24.04.2015 13:04:38 Gast46398
NotSolved
24.04.2015 22:09:56 Gast49987
NotSolved
Rot Calculate ...Eine Änderung erkennen
26.04.2015 18:28:28 Gast33454
NotSolved
29.04.2015 07:20:37 Seddi
NotSolved
29.04.2015 07:35:00 Seddi
NotSolved