|
Hallo Denis,
wie wär's mit diesem Code?
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
Zur Erklärung: der Code prüft in jeder Spalte ob es Zeilen mit Farbe gibt. Wenn ja, zählt er in jeder dieser Zeilen die noch freien farbigen Zellen. die Zeilen mit den wenigsten noch freien farbigen Zellen (beginnend in der jeweiligen Spalte) werden dabei herausgepickt und die 1 vergeben. Probiers aus.
Gruß Mr. K.
|