Sub
ElternAbend()
Dim
Matrix
As
Range, cl
As
Range, rw
As
Range, r
As
Range, arr()
As
Range, c
As
Variant
Dim
i
As
Long
, Min
As
Long
, z
As
Long
Set
Matrix = Range(
"B2:I8"
)
lastcol = Matrix.Column + Matrix.Columns.Count - 1
For
Each
cl
In
Matrix.Columns
ReDim
arr(0)
For
Each
rw
In
cl.Rows
If
Not
rw.Interior.ColorIndex = xlNone
Then
ReDim
Preserve
arr(UBound(arr) + 1)
Set
r = rw
For
i = rw.Column + 1
To
lastcol
If
Not
Cells(rw.Row, i).Interior.ColorIndex = xlNone
Then
Set
r = Union(r, Cells(rw.Row, i))
End
If
Next
i
Set
arr(UBound(arr)) = r
End
If
Next
rw
Min = lastcol
z = 0
For
i = 1
To
UBound(arr)
If
arr(i).Cells.Count < Min
And
Application.CountA( _
Range(Cells(arr(i).Row, Matrix.Column), Cells(arr(i).Row, lastcol))) = 0
Then
Min = arr(i).Cells.Count
z = arr(i).Row
End
If
Next
i
If
z > 0
Then
Cells(z, cl.Column).Value = 1
Next
cl
End
Sub