Change-Ereignis für viele Blätter/zellen

Hallo Wissende,
aufgrund einer Anfrage woanders habe ich jmndm. Code gebastelt, der im Change-Ereignis abprüft of die Änderung in einem von 13 festgelegten Blättern und dort in einer von 10 festgelgten Spalten stattfand.
Noch dazu muß es immer in den Zeilen 98:103 geschehen.
(Änderungen gleichzeitig in mehreren zellen muß ich noch einbauen)
Dazu habe ich die Funktion Check geschrieben. Nach meinen bisherigen Tests funktioniert sie auch richtig.
Nur, sie kommt mir so lang vor, kann man sie kürzen?
Mir fällt dazu nur ein ellenlanger
If Intersect(Target, Range(....)) then
ein, aber der ginge ja auch über zig Zeilen wenn man ihn umbricht.
In "Diese Arbeitsmappe":

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Check(Sh, Target) = True Then Call Auswahl
End Sub

In "Modul1"

Function Check(Sh, Target)
Dim arrBlatt(), B As Integer, S As Integer
Dim arrSpa()
arrBlatt = Array("Gesundheitsförderung", "Ernährung", "Ausscheidung", _
"Aktivität Ruhe", "Perzeption Kognition", "Selbstwahrnehmung", _
"Rolle Beziehungen", "Sexualität", "Coping Stresstoleranz", _
"Lebensprinzipien", "Sicherheit Schutz", "Befinden", "Wachstum Entwicklung")
arrSpa = Array("B", "F", "J", "N", "R", "V", "Z", "AD", "AH", "AL")
For B = LBound(arrBlatt) To UBound(arrBlatt)
If Sh.Name = arrBlatt(B) Then
Check = True
Exit For
End If
Next B
If Check = False Then Exit Function
Check = False
For S = LBound(arrSpa) To UBound(arrSpa)
If Target.Column = Range(arrSpa(S) & "1").Column Then
Check = True
Exit For
End If
Next S
If Check = False Then Exit Function
Check = False
If Target.Row >= 98 And Target.Row

Danke ^ ruß
Reinhard

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Reinhard,

Function Check(Sh As Worksheet, Target As Range) As Boolean
  Dim arrBlatt() As Variant

  arrBlatt = Array("Gesundheitsförderung", "Ernährung", "Ausscheidung", _
    "Aktivität Ruhe", "Perzeption Kognition", "Selbstwahrnehmung", _
    "Rolle Beziehungen", "Sexualität", "Coping Stresstoleranz", _
    "Lebensprinzipien", "Sicherheit Schutz", "Befinden", "Wachstum Entwicklung")

  Check = IsNumeric(Application.Match(Sh.Name, arrBlatt, 0))

  If Check Then
    Select Case Target.Column
      Case 2, 6, 10, 14, 18, 22, 26, 30, 34, 38
      Case Else: Check = False
    End Select
    If Check Then
      Check = Target.Row >= 98 And Target.Row <= 103
    End If
  End If

End Function

Gruß Sepp

'ohne Function Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim Zelle As Range Select Case Sh.Name Case "Gesundheitsförderung", "Ernährung", "Ausscheidung", _ "Aktivität Ruhe", "Perzeption Kognition", "Selbstwahrnehmung", _ "Rolle Beziehungen", "Sexualität", "Coping Stresstoleranz", _ "Lebensprinzipien", "Sicherheit Schutz", "Befinden", "Wachstum Entwicklung" For Each Zelle In Target Select Case Zelle.Column Case 2 To 38 If (Zelle.Column + 2) Mod 4 = 0 Then ' jede 4. Spalte Select Case Zelle.Row Case 98 To 103 Call auswahl End Select End If End Select Next Zelle End Select End Sub ' oder mit Function Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim Zelle As Range For Each Zelle In Target If Check(Sh, Zelle) = True Then Call auswahl End If Next Zelle End Sub Function Check(wks As Worksheet, rZelle As Range) As Boolean Select Case wks.Name Case "Gesundheitsförderung", "Ernährung", "Ausscheidung", _ "Aktivität Ruhe", "Perzeption Kognition", "Selbstwahrnehmung", _ "Rolle Beziehungen", "Sexualität", "Coping Stresstoleranz", _ "Lebensprinzipien", "Sicherheit Schutz", "Befinden", "Wachstum Entwicklung" Select Case rZelle.Column Case 2, 6, 10, 14, 18, 22, 26, 30, 34, 38 Select Case rZelle.Row Case 98 To 103 Check = True End Select End Select End Select End Function

Beliebteste Forumthreads (12 Monate)

Change-Ereignis für viele Blätter/zellen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread