Office: Worksheet_Change auf mehrere Zellen anwenden?

Chicken Wing · 17. Juli 2012

Hallo zusammen,

ich habe bei unten stehendem Code das Problem, das ich auf Tabelle1 verweisen möchte und von dort die Werte nehmen möchte. Weiterhin habe ich das Problem, das sich das Ganze auf mehrere Zellen wiederholt Ich habe die Datei mal angehangen. Die Werte, die ich nicht für die Berechnung brauche sind rot und die ich benötige sind grün markiert.
Wäre schön, wenn mir jemand helfen könnte.

Danke und Gruß
Chicken Wing

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range
Dim rngzelle As Range
'Bereich eingrenzen bei dem das Change Ereignis ausgelöst wird

Set rngBereich = Intersect(Target, Range("D3:J7"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Cells(1, Target.Column).Value
Next rngzelle
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

IngGi · 19. Juli 2012

Hallo Chicken Wing,

wenn es nur die 3 grünen Bereiche gibt, könntest du diese mit Union zusammenfassen:

Private Sub Worksheet_Change(ByVal Target As Range)Dim rngBereich As RangeDim rngZelle As Range'Bereich eingrenzen bei dem das Change Ereignis ausgelöst wirdSet rngBereich = Intersect(Target, Union(Range("D1:K5"), Range("D9:K13"), Range("D17:K21")))If Not rngBereich Is Nothing Then On Error GoTo ErrorHandler Application.EnableEvents = False For Each rngZelle In rngBereich rngZelle.Value = rngZelle.Value * Worksheets("Tabelle1") _ .Cells(1, Target.Column).Value Next rngZelleEnd IfErrorHandler:Application.EnableEvents = TrueEnd Sub VBA/HTML - CodeConverter für ExcelforenAddIn für Excel XP+2003 - komplett in VBA geschrieben von IngGiAnbindung an VBE-Kontextmenü geklaut ;-) bei:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn es allerdings noch ein paar mehr "grüne Bereiche" sind, wird das Ganze schnell ziemlich sperrig. Dann würde ich die gültigen Zeilen eher über das Modulo bestimmen:

Private Sub Worksheet_Change(ByVal Target As Range)On Error GoTo ErrorHandler'Höchste Zeile anpassen, wenn mehr als die 3 Bereiche in deinem BeispielFor Each rngZelle In Intersect(Target, Range("D1:K22")) If rngZelle.Row Mod 8 > 0 Then 'Nicht Zeile 8, 16, usw. If rngZelle.Row Mod 8 < 6 Then 'Nicht Zeile 6/7, 14/15, usw. Application.EnableEvents = False rngZelle.Value = rngZelle.Value * Worksheets("Tabelle1") _ .Cells(1, Target.Column).Value Application.EnableEvents = True End If End IfNext 'rngZelleErrorHandler:Application.EnableEvents = TrueEnd Sub VBA/HTML - CodeConverter für ExcelforenAddIn für Excel XP+2003 - komplett in VBA geschrieben von IngGiAnbindung an VBE-Kontextmenü geklaut ;-) bei:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Den Bezug auf Tabelle1 habe ich in beide Codes eingebaut.

Gruß Ingolf

Chicken Wing · 19. Juli 2012

Hallo,

eigentlich meinte ich das etwas anders.

Ich habe die Datei noch einmal erweitert und angehangen.

Mir geht es darum folgenden VBA-Code wesentlich zu verkürzen. Es gibt doch bestimmt eine Lösung, das ich das nicht für jede Zelle von Tabelle1 machen muß:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range
Dim rngzelle As Range
'Bereich eingrenzen bei dem das Change Ereignis ausgelöst wird

Set rngBereich = Intersect(Target, Range("D3:J3"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(1, Target.Column).Value
Next rngzelle
End If
ErrorHandler:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D4:J4"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler2
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(2, Target.Column).Value
Next rngzelle
End If
ErrorHandler2:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D5:J5"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler3
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(3, Target.Column).Value
Next rngzelle
End If
ErrorHandler3:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D6:J6"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler4
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(4, Target.Column).Value
Next rngzelle
End If
ErrorHandler4:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D7:J7"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler5
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(5, Target.Column).Value
Next rngzelle
End If
ErrorHandler5:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D11:J11"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler6
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(7, Target.Column).Value
Next rngzelle
End If
ErrorHandler6:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D12:J12"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler7
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(8, Target.Column).Value
Next rngzelle
End If
ErrorHandler7:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D13:J13"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler8
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(9, Target.Column).Value
Next rngzelle
End If
ErrorHandler8:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D14:J14"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler9
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(10, Target.Column).Value
Next rngzelle
End If
ErrorHandler9:
Application.EnableEvents = True

Set rngBereich = Intersect(Target, Range("D15:J15"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler10
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(11, Target.Column).Value
Next rngzelle
End If
ErrorHandler10:
Application.EnableEvents = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Danke und Gruß
Chicken Wing

Hajo_Zi · 19. Juli 2012

ohne Test.
Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range
Dim rngzelle As Range
'Bereich eingrenzen bei dem das Change Ereignis ausgelöst wird
Set rngBereich = Intersect(Target, Range("D3:J7"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(Rng.Row - 2, Target.Column).Value
Next rngzelle
End If
ErrorHandler:
Set rngBereich = Intersect(Target, Range("D11:J15"))
If Not rngBereich Is Nothing Then
On Error GoTo ErrorHandler6
Application.EnableEvents = False
For Each rngzelle In rngBereich
rngzelle.Value = rngzelle.Value * Worksheets("Tabelle1").Cells(Rng.Row - 4, Target.Column).Value
Next rngzelle
End If
ErrorHandler6:
Application.EnableEvents = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hajo_Zi · 19. Juli 2012

kleinen Fehler noch Beseitigt.
Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range
Dim rngzelle As Range
'Bereich eingrenzen bei dem das Change Ereignis ausgelöst wird
Application.EnableEvents = False
Set rngBereich = Intersect(Target, Range("D3:J7"))
On Error GoTo ErrorHandler
If Not rngBereich Is Nothing Then
For Each rngzelle In rngBereich
rngzelle = rngzelle * Worksheets("Tabelle1").Cells(rngzelle.Row - 2, Target.Column)
Next rngzelle
Else
Set rngBereich = Intersect(Target, Range("D11:J15"))
If Not rngBereich Is Nothing Then
For Each rngzelle In rngBereich
rngzelle = rngzelle * Worksheets("Tabelle1").Cells(rngzelle.Row - 4, Target.Column)
Next rngzelle
End If
End If
ErrorHandler:
On Error GoTo 0
Set rngBereich = Nothing
Application.EnableEvents = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Chicken Wing · 22. Juli 2012

Hallo noch einmal,

das funktioniert super. Allerdings muß ich noch mehrere Bereiche abdecken,
also mit if then else... ( eine Menge Bereiche *boah ) Wie kann ich das denn verschachteln, das es funktioniert?

Vielen Dank und Gruß
Chicken Wing

Chicken Wing · 23. Juli 2012

keiner eine idee ???

Hajo_Zi · 23. Juli 2012

keine Idee, da keine genaue Aufgabe.

Chicken Wing · 23. Juli 2012

Hallo Hajo,

ich habe die Datei noch einmal angehängt. Ich meinte das so, das die Tabelle "Kino" bestimmt 1000 Reihen lang wird. Dementsprechend muß dann auch der VBA-Code so lang werden. Ich muß also für jeden Block eine IF Anweisung einbauen. Das sieht nicht nur bescheiden aus, sondern ist ein großer Aufwand. Jetzt wollte ich gerne wissen, ob es eine Möglichkeit, das Ganze eleganter zu gestalten, z.B. mit einer Case Anweisung oder so.

Gruß Chicken Wing

Hajo_Zi · 23. Juli 2012

Gut icfh kann damit Leben das Du keine genaue Aufgabenstellung liefern willst. Ich habe nicht das Problem.
Der erste Bereich hat -2, der zwweite Berreich hat -4, der 3 Bereich vielleicht -6?
Diese Zahl sollte man in den Zeilen in eine Spalte schreiben.
Ich bin aus o.g. raus.

Chicken Wing · 23. Juli 2012

Hallo Hajo,

die Aufgabenstellung bezieht sich eben darauf, das sehr viele IF Anweisungen im VBA Code stehen. Und meine Frage ist nun, ob die Möglichkeit besteht den VBA Code zu verkleinern, indem man die IF Anweisung beispielsweise mit dem Befehl CASE kürzen kann. Diese "Blöcke" in der Tabelle sollen weiter geführt werden. Diese Blöcke werden sich dann auf die jeweilige Woche beziehen. Da das Jahr ca. 52 Wochen hat und somit der VBA Code immer mit der IF Anweisung erweitert werden muß (-2, -4, -6, -8 usw. ) wird der ganze Code furchtbar unübersichtlich. Unten ist der Teilcode, um den es hauptsächlich geht.

Also, kann man den Code verkürzen und überschaubar machen?

Vielen Dank und Gruß
Chicken Wing

Code:

If Not rngBereich Is Nothing Then
For Each rngzelle In rngBereich
rngzelle = rngzelle * Worksheets("Tabelle1").Cells(rngzelle.Row - 2, Target.Column)
Next rngzelle
Else
Set rngBereich = Intersect(Target, Range("D11:J15"))
If Not rngBereich Is Nothing Then
For Each rngzelle In rngBereich
rngzelle = rngzelle * Worksheets("Tabelle1").Cells(rngzelle.Row - 4, Target.Column)
Next rngzelle
End If
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Chicken Wing · 25. Juli 2012

*push*biggrin.gif*

Office: Worksheet_Change auf mehrere Zellen anwenden?

Worksheet_Change auf mehrere Zellen anwenden?

Worksheet_Change auf mehrere Zellen anwenden?

Worksheet_Change auf mehrere Zellen anwenden?

Worksheet_Change auf mehrere Zellen anwenden?

Worksheet_Change auf mehrere Zellen anwenden? - Similar Threads - Worksheet_Change Zellen anwenden

Problem mit Private Sub Worksheet_Change

2x Worksheet_Change(ByVal Target As Range)

VBA - Fehler beim Kompilieren (Mehrdeutiger Name - Worksheet_Change)

worksheet_change alternative bei Zellen mit Formeln

2x Private Sub Worksheet_Change(ByVal Target As Range)

VBA Autoform einfärben

Worksheet_Change auf bestimmte Zeilen beschränken