Sry,
für bool´sche Logik bin ich heut wohl zu platt ;)
Dann nehme ich mal die "Finger" zum Zählen !
Option Explicit
Sub Test()
Dim myWs As Worksheet
Dim Z As Double
Dim J As Long
Dim i As Long
Dim R As Long
Dim Zeile() As Long
Dim stp() As Integer
Dim aZ As Long
'
Dim Tr As Integer 'Treffer in Spalte
Dim Zr As Integer 'alle Suche in Spalte
'
For Each myWs In ActiveWorkbook.Sheets
If InStr(myWs.Name, "Cluster") Then
Z = myWs.Cells(1, 4).Interior.Color
R = myWs.Cells(Rows.Count, 2).End(xlUp).Row
ReDim Zeile(1 To R)
ReDim stp(1 To R)
For J = 1 To R
If myWs.Cells(J, 2) <> 0 Then
stp(J) = myWs.Cells(J, 2).Value
Zeile(J) = Sheets("Tabelle1").Columns("A:A").Find(What:=stp(J), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
End If
Next J
For i = 2 To 10
Tr = 0
Zr = 0
For aZ = 3 To UBound(Zeile)
If Sheets("Tabelle1").Cells(Zeile(aZ), i).Value = "x" Then
Tr = Tr + 1
Zr = Zr + 1
Else
Zr = Zr + 1
End If
Next aZ
'
If Tr = Zr Then
Range(Sheets("tabelle1").Cells(Zeile(1), i), _
Sheets("tabelle1").Cells(Zeile(2) - 1, i)).Select
Sheets("tabelle1").Cells(Zeile(2) - 1, i).Activate
'
With Selection.Interior
.Color = Z
End With
End If
Next i
End If
Next myWs
End Sub
|