Multiplizieren aller farbigen Zellen in einem Zeilenabschnitt

Question

Hallo,

gestern habe ich gelenert, wie man Zellen per Doppelklick farbig macht und die farbigen zellen summiert (mit Addition).

Nun sollen allerdings die farbigen zellen nicht mehr addiert, sondern multipliziert werden.

Dementsprechend habe ich aus dblSumme dblProdukt gemacht, aber der gewünschte erfolg lässt bislang aus. Das lässt mich schier verzweifeln.

Hier noch kurz der Code, mit dem ich addieren kann.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngZelle As Range
Dim dblProdukt As Double

Select Case Target.Row


Case 8 'Spalte G
If Target.Cells.Interior.ColorIndex = 4 Then
'Farbe aufheben
Target.Cells.Interior.ColorIndex = 0
Else
'Farbe zuweisen
Target.Cells.Interior.ColorIndex = 4
End If
'Zellen mit Hintergrundfarbe zählen
For Each rngZelle In Range("C8:K8")
If rngZelle.Interior.ColorIndex = 4 Then
On Error Resume Next
dblProdukt = dblProdukt * rngZelle
On Error GoTo 0
End If
Next
Range("L8") = dblProdukt
End Select
End Sub

hier war bei der Summierung ein + dblProdukt = dblProdukt * rngZelle

schon mal vielen Dank

Gruß Florian

Answer 1

Hallo Florian,

um bei Denem gestrigen Beispiel zu bleiben, würde der Code zum Multiplizeren der Werte in Farbzellen so lauten:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngC As Range, dblZ As Double, intFarbe As Integer
If Not Intersect(Target, Range("A8:K8,A10:K10,A12:K12,A14:K14")) Is Nothing Then
On Error Resume Next
dblZ = 1
Select Case Target.Row
Case 8
If Target.Interior.ColorIndex = 4 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 4
End If
intFarbe = 4
Case 10
If Target.Interior.ColorIndex = 6 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 6
End If
intFarbe = 6
Case 12
If Target.Interior.ColorIndex = 3 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 3
End If
intFarbe = 3
Case 14
If Target.Interior.ColorIndex = 5 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 5
End If
intFarbe = 5
End Select
For Each rngC In Range(Cells(Target.Row, 1), Cells(Target.Row, 11))
If rngC.Interior.ColorIndex = intFarbe Then
dblZ = dblZ * rngC
End If
Next
Cells(Target.Row, 12).Value = dblZ
End If
End Sub

Gruß
Rainer

Answer 2

Hallo Rainer,

vielen Dank.

Ist es möglich, dass, wenn in einer Zeile nichts farbig ist, eine 0 in Spalte 12 steht? Jetzt wirft es eine 1 aus.

Kannst du mir bitte noch die Befehle dazu kurz erklären? Was macht was. (Und wenn es dir nicht allzu viel Mühe macht, auch die von gestern?) - Und warum ist "Produkt" hier nicht der richtige Weg?


Gruß Florian

Answer 3

Hallo Florian,

die Variable dblProdukt hat in Deinem Makro den Ausgangswert 0.
In der Mathematik haben wir gelernt, dass eine Multiplikation mit 0 immer 0 ergibt.
Somit hat Dein Code auch recht.

Du müsstest also der beagten Variablen am Anfan des Makros den Wert 1 zuweisen.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngZelle As Range
Dim dblProdukt As Double
dblProdukt = 1
Select Case Target.Row
Case 8 'Spalte G
If Target.Cells.Interior.ColorIndex = 4 Then
'Farbe aufheben
Target.Cells.Interior.ColorIndex = 0
Else
'Farbe zuweisen
Target.Cells.Interior.ColorIndex = 4
End If
'Zellen mit Hintergrundfarbe zählen
For Each rngZelle In Range("C8:K8")
If rngZelle.Interior.ColorIndex = 4 Then
On Error Resume Next
dblProdukt = dblProdukt * rngZelle
On Error GoTo 0
End If
Next
Range("L8") = dblProdukt
End Select
End Sub

Gruß
Rainer

Answer 4

Hallo Rainer,

soweit hab ich jetzt auch Produkt verstanden.

Ist es aber trotzdem möglich, dass in der Spalte 12, in der das Ergebnis steht, eine 0 ausgibt, wenn keine Zelle in der Zeile farbig ist, anstelle der 1.


Und bitte noch dies erklären. was macht was? Das würde mir schon richtig weiter helfen. Danke

Dim rngC As Range, dblZ As Double, intFarbe As Integer
If Not Intersect(Target, Range("A8:K8,A10:K10,A12:K12,A14:K14")) Is Nothing Then
On Error Resume Next
dblZ = 1
Select Case Target.Row


Gibt das Ergebnis aus?! was macht das Value?

For Each rngC In Range(Cells(Target.Row, 1), Cells(Target.Row, 11))
If rngC.Interior.ColorIndex = intFarbe Then
dblZ = dblZ * rngC
End If
Next
Cells(Target.Row, 12).Value = dblZ
End If

Danke schon mal.

Gruß Florian

Answer 5

Hi Florian,

wenn ich dein Anliegen richtig verstanden habe, würde ich es so lösen:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngZelle As Range
Dim dblProdukt As Double
Dim blnAusgabe As Boolean
dblProdukt = 1
If Target.Row = 8 Then
Cancel = True
If Target.Interior.ColorIndex = 4 Then
'Farbe aufheben
Target.Interior.ColorIndex = xlNone
Else
'Farbe zuweisen
Target.Interior.ColorIndex = 4
End If
For Each rngZelle In Range("C8:K8")
' falls Zellinhalt numerisch und nicht 0 und Füllfarbe Grün
If IsNumeric(rngZelle) And rngZelle <> 0 And rngZelle.Interior.ColorIndex = 4 Then
dblProdukt = dblProdukt * rngZelle.Value
blnAusgabe = True
End If
Next rngZelle
' nur eintragen wenn dblProdukt tasächlich belegt wurde
If blnAusgabe Then Range("L8") = dblProdukt
End If
End Sub

Ich nehme an, On Error Resume next hast du verwendet, da auch Zellen mit Text im betreffenden Bereich vorkommen können. Den dann auftretenden Fehler kann man anders abfangen indem man prüft, ob der Inhalt der Zelle numerisch ist. Ich nehme außerdem an, dass das Produkt nicht gebildet werden soll, wenn eine Zelle 0 enthält, denn dann ist das Gesamtprodukt ebenfalls 0.

Mit der Variablen blnAusgabe wird geprüft, ob der Code tatsächlich ein Produkt gebildet hat, dann wenn dies nicht der Fall ist, wird andernfalls am Ende in L8 eine 1 eingetragen, da dblProdukt zu Beginn mit 1 belegt wurde.

Die Zeile Cancel = True ist dazu da, dass nach Ausführung des Doppelklicks der Editiermodus abgeschaltet wird, da man andernfalls in der doppelgeklickten Zelle "festhängt".

Bis später,
Karin

Answer 6

Hallo Florian,

Karin ist eben die Spezialistin für VBA.

Trotzdem möchte ich Dir meinen angepsssten Code nicht vorenthalten, was Du nun verwendest kannst Du selbst entscheiden
Leider kann ich Dir aus Zeitgründen keinen VBA-Grundkurs bieten, musst Dich schon bei Unklarheiten etwas mehr mit der VBA-Hilfe anfreunden.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngC As Range, dblProdukt As Double, intFarbzähler As Integer, intFarbe As Integer
If Not Intersect(Target, Range("A8:K8,A10:K10,A12:K12,A14:K14")) Is Nothing Then
'*****bestimmt wirksammen Bereich****
On Error Resume Next
dblProdukt = 1
Select Case Target.Row
Case 8
If Target.Interior.ColorIndex = 4 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 4
End If
intFarbe = 4
Case 10
If Target.Interior.ColorIndex = 6 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 6
End If
intFarbe = 6
Case 12
If Target.Interior.ColorIndex = 3 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 3
End If
intFarbe = 3
Case 14
If Target.Interior.ColorIndex = 5 Then
Target.Interior.Pattern = xlNone
Else
Target.Interior.ColorIndex = 5
End If
intFarbe = 5
End Select
For Each rngC In Range(Cells(Target.Row, 1), Cells(Target.Row, 11))
If rngC.Interior.ColorIndex = intFarbe Then
dblProdukt = dblProdukt * rngC
intFarbzähler = intFarbzähler + 1
End If
Next
If intFarbzähler > 0 Then
Cells(Target.Row, 12).Value = dblProdukt
Else
Cells(Target.Row, 12).Value = 0
End If
End If
End Sub

Gruß
Rainer

Answer 7

Hallo Karin, hallo Rainer,

danke für die Einführung ins VBA. Das bringt mich auf jeden Fall schon wiede ein Stück weiter.

Code Funktioniert super. (Sogar mit der 0).

Ich hoffe, ich kann bald anderen Usern ebenso helfen.

Gruß Florian

Answer 8

Hi Florian,

da du VBA-Anfänger bist, mal nur ein Hinweis am Rande: die Verwendung von On Error Resume Next zur Fehlerbehandlung sollte man nur verwenden, wenn es keine andere Möglichkeit gibt, oder wenn man es zielgerichtet und bewusst einsetzt, um bestimmte Reaktionen auszulösen. Andernfalls ist das "unsaubere" (Rainer - bitte nicht persönlich nehmen) Programmierung und kann gegebenenfalls verherende Folgen für ein Projekt haben - man wundert sich dann, weshalb nicht das gewünschte Ergebnis erzielt wird und kann nicht nachvollziehen, wo der Fehler im Code liegt. Also immer Vorsicht mit On Error Resume Next!

Das Eintragen von 0 kann man übrigens auch in meinem Code realisieren:

If blnAusgabe Then
Range("L8") = dblProdukt
Else
Range("L8") = 0
End If

Man kann auch - anstelle 0 einzutragen - z.B. den Zellinhalt löschen, sodass die Zelle dann leer bleibt:

If blnAusgabe Then
Range("L8") = dblProdukt
Else
Range("L8").ClearContents
End If

Bis später,
Karin

Answer 9

Hallo Karin,

Rainer - bitte nicht persönlich nehmen

...kein Problem, war doch ein guter Hinweis.

Eigentlich verwende ich die Fehlerabfrage (für Faule oder Unwissende) "On Error Resume Next" sonst auch nicht, mir war nur auf die Schnelle nichts Besseres eingefallen, zumal es in vielen Fällen auch keinen Schaden anrichtet.

Gruß
Rainer