AW: Link
17.12.2021 10:42:25
UweD
Hallo
so?
Ich frage den Wert in BB auch ab. Grenze liegt bei 11
Option Explicit
Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RNGAsw As Range, RNGA As Range, RNGB As Range, RNGC As Range
Dim RNG1 As Range, RNG11 As Range, RNG12 As Range, RNG2 As Range, RNG3 As Range
Dim Sp As Integer, Z As Integer, i As Integer, Such As Variant
Dim RNGBF As Range, BF As Integer, BFGrenz As Integer, Anz As Integer
Set RNGAsw = Range("Z:BJ") 'Reaktionsbereich
Set RNGA = Range("AG:AL") 'Midi
Set RNGB = Range("AN:AS") 'Note
Set RNGC = Range("AU:AZ") 'TonHöhe
Set RNG11 = Range("B3:M8") 'bis 11
Set RNG12 = Range("N3:V8") 'ab 11
Set RNG2 = Range("B11:V16")
Set RNG3 = Range("B19:V24")
Set RNGBF = Range("BB:BB") 'BaseFret Bereich
BFGrenz = 11 'Doppelte Noten ab
If Not Intersect(RNGAsw, Target) Is Nothing Then
If Target.Rows.Count > 1 Then
MsgBox "Nur eine Zeile auswählen"
Exit Sub
End If
Z = Target.Row
'Reset
Union(RNG11, RNG12, RNG2, RNG3).Interior.Pattern = xlNone
' Suchen in Midi
For i = 6 To 1 Step -1
Such = Intersect(RNGA.Rows(Z), RNGA.Columns(6 - i + 1)).Value
If Such "x" And Such "" Then
Sp = WorksheetFunction.Match(Such, RNG2.Rows(i), 0)
With Intersect(RNG2, RNG2.Rows(i), RNG2.Columns(Sp))
.Interior.Color = 65280
End With
End If
Next
' Suchen in Note
BF = Intersect(RNGBF, Rows(Z)).Value 'BaseFred
For i = 6 To 1 Step -1
Such = Intersect(RNGB.Rows(Z), RNGB.Columns(6 - i + 1)).Value
If Such "x" And Such "" Then
Anz = WorksheetFunction.CountIf(Union(RNG11, RNG12).Rows(i), Such)
If Anz = 1 Then
Set RNG1 = Union(RNG11, RNG12)
Else
If BF >= BFGrenz Then
Set RNG1 = RNG12
Else
Set RNG1 = RNG11
End If
End If
Sp = WorksheetFunction.Match(Such, RNG1.Rows(i), 0)
With Intersect(RNG1, RNG1.Rows(i), RNG1.Columns(Sp))
.Interior.Color = 65280
End With
End If
Next
' Suchen in Tonhöhe
For i = 6 To 1 Step -1
Such = Intersect(RNGC.Rows(Z), RNGC.Columns(6 - i + 1)).Value
If Such "x" And Such "" Then
Sp = WorksheetFunction.Match(Such, RNG3.Rows(i), 0)
With Intersect(RNG3, RNG3.Rows(i), RNG3.Columns(Sp))
.Interior.Color = 65280
End With
End If
Next
End If
End Sub
LG UweD
