Hallo Forum,
ich habe hier einen Code, den ich mir aus einem anderen Forum her zusammengebastelt habe. Leider habe ich ein kleines Problem.
Der Code funktioniert wunderbar mit ganzen Zahlen. Sobald ich allerdings eine Zahl mit Nachkommstelle habe (Dezimalzahl) funktioniert er nicht mehr.
Zu Erklärung was der Code macht bzw. wie meine Tabelle aufgebaut ist:
In Spalte M:M werden Werte aus anderen Zellen zusammengerechnet.
In Spalte J:J wird die Zahl aus M:M automatisch eingetrage.
Wenn sich in der Spalte M:M etwas an der Zahl ändert wird diese automatisch auch in J:J eingetragen.
Allerdings nur solange ich den Wert in J:J nicht überschrieben habe. Wenn ich einen überschriebenen Wert wieder lösche, wird wieder der Wert aus M:M eingetragen.
So weit so gut... das funktiniert wunderbar. Wenn nun allerdings das Ergebnis in einer Zelle aus M:M eine Dezimalzahl ist, funktioniert der Code nicht mehr.
Ich hoffe nun, das mir jemand aus diesem Forum weiter helfen kann, so dass der Code auch mit Dezimalzahlen funktioniert. Hier der Code
Modul
' Array-Variablen zum Speichern der Werte
Public arrG(65535) As Long
Diese Arbeitsmappe
Private Sub Workbook_Open()
' Speichern der aktuellen Werte
Dim rgG As Range, i As Long
'Alle M-Zellen
Set rgG = Range("M:M")
i = 0
For Each c In rgG
arrG(i) = c.Value
i = i + 1
Next
End Sub
Tabelle1
Private Sub Worksheet_Calculate()
' Im Tabellenblatt wurde eine Berechnung durchgeführt
Dim i As Long, zeile As Long
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
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' Weiterhin für manuelle Änderung in J-Zellen
Dim rC As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("M:M")) 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("J:J")) 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
Ich würde mich über Hilfe sehr freuen
Mit besten Grüßen
Mario
|