Oh, das ist wohl was schief gelaufen,

also hier noch einmal verständlich.

Hallo zusammen,

nun kann ich wirklich sagen, dass der Code funktioniert. Ich habe ihn umfangreich getest und habe bis jetzt keine technischen Schwierigkeiten festgestellt. Ein Frage habe ich allerdings noch.Ich habe festgestellt, dass die Berechnung bei ein Änderung mit unter recht lange dauert (bis zu 15 Sekunden). Der Code wird im Moment auf ca. 25 Arbeitsblättern ausgeführt. Kann es sein, dass es daran liegt, dass der Code nun unter DieseArbeitmappe; steht und daher bei jeder Änderung auf allen 25 Arbeitsblättern durchgeführt wird auch wenn die Änderung nur auf einem Arbeitsblatt erfolgt.

Als der Code noch in jedem einzelnen Arbeitsblatt eingetragen war, ging die Berechnung deutlich schneller. Allerdings war sie fehlerhaft (siehe Beiträge zuvor). Nun stellen sich für mich zwei Fragen: 1. Woran liegt es, dass die Berechnung so lange dauert? 2. Gibt es eine Möglichkeit den Code so zu schreiben, dass er effektiver Arbeitet?

Im Moment sieht der Code so aus

Diese Arbeitsmappe:

Private Sub Workbook_open()

' Speichern der aktuellen Werte
Dim rgG As Range, i As Double
 
'Alle M-Zellen
Set rgG = Range("M1:M400")
i = 0
 
For Each C In rgG
    arrG(i) = C.Value
    i = i + 1
Next
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Eingabe Kundendaten" Or Sh.Name = "Eingabe FM-Dienste" Or Sh.Name = "Listen" Or Sh.Name = "Steuerelemente Angaben" Or Sh.Name = "Basistabelle Instandhalten" Or Sh.Name = "Druckbereiche" Or Sh.Name = "Basistabelle Heizenergie" Or Sh.Name = "VonBisWerte" Or Sh.Name = "Tilgungsplan" Then Exit Sub
Application.EnableEvents = False
' Im Tabellenblatt wurde eine Berechnung durchgeführt
Dim i As Double, zeile As Double
zeile = 0
' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?)
For i = 0 To UBound(arrG)
    zeile = i + 1
    ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ...
    If arrG(i) <> Cells(zeile, 13) Then
        ' ...: wenn Zelle J = alter Wert M, dann
        If Cells(zeile, 10) = arrG(i) Then
            ' Wertzuweisung J-Zelle und neuer Wert, ...
            arrG(i) = Cells(zeile, 13)
            Cells(zeile, 10) = Cells(zeile, 13)
        Else
            ' ...sonst nur M-Zelle in Array
            arrG(i) = Cells(zeile, 13)
        End If
    End If
Next
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
If Sh.Name = "Eingabe Kundendaten" Or Sh.Name = "Eingabe FM-Dienste" Or Sh.Name = "Listen" Or Sh.Name = "Steuerelemente Angaben" Or Sh.Name = "Basistabelle Instandhalten" Or Sh.Name = "Druckbereiche" Or Sh.Name = "Basistabelle Heizenergie" Or Sh.Name = "VonBisWerte" Or Sh.Name = "Tilgungsplan" Then Exit Sub
Application.EnableEvents = False
' Im Tabellenblatt wurde eine Berechnung durchgeführt
Dim i As Double, zeile As Double
zeile = 0
' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?)
For i = 0 To UBound(arrG)
    zeile = i + 1
    ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ...
    If arrG(i) <> Cells(zeile, 13) Then
        ' ...: wenn Zelle J = alter Wert M, dann
        If Cells(zeile, 10) = arrG(i) Then
            ' Wertzuweisung J-Zelle und neuer Wert, ...
            arrG(i) = Cells(zeile, 13)
            Cells(zeile, 10) = Cells(zeile, 13)
        Else
            ' ...sonst nur M-Zelle in Array
            arrG(i) = Cells(zeile, 13)
        End If
    End If
Next
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Eingabe Kundendaten" Or Sh.Name = "Eingabe FM-Dienste" Or Sh.Name = "Listen" Or Sh.Name = "Steuerelemente Angaben" Or Sh.Name = "Basistabelle Instandhalten" Or Sh.Name = "Druckbereiche" Or Sh.Name = "Basistabelle Heizenergie" Or Sh.Name = "VonBisWerte" Or Sh.Name = "Tilgungsplan" Then Exit Sub
' Weiterhin für manuelle Änderung in J-Zellen
    Dim rC As Range
    Application.EnableEvents = False
    If Not Intersect(Target, Range("M1:M400")) Is Nothing Then
        For Each rC In Target
            If rC.Column = 13 Then
                If rC.Offset(0, -3) = "" Then rC.Offset(0, -3) = rC
            End If
        Next rC
    End If
    If Not Intersect(Target, Range("J1:J400")) Is Nothing Then
        For Each rC In Target
            If rC.Column = 10 Then
                If rC = "" Then rC = rC.Offset(0, 3)
            End If
        Next rC
    End If
    Application.EnableEvents = True
End Sub

Modul:

' Array-Variablen zum Speichern der Werte
Public arrG(65535) As Double

Ich würde mich über Hilfe sehr freuen

Gruß

Mario