AW: Brauche einen Profi, oder auch mehrere !
Roland
Hallo Werner,
schau mal obs passt:
Option Explicit
Sub Werte_Ausfuellen()
Dim i As Integer, j As Integer, k As Integer
Dim rngBereich1 As Range, rngBereich2 As Range, rngBereich3 As Range, rngBereich4 As Range, Gesamt As Range
Dim Zelle As Range
Application.ScreenUpdating = False
Set rngBereich1 = Range("N4:N7")
Set rngBereich2 = Range("N14:N17")
Set rngBereich3 = Range("N24:N27")
Set rngBereich4 = Range("N34:N37")
Set Gesamt = Union(rngBereich1, rngBereich2, rngBereich3, rngBereich4)
Gesamt.Select
Range("N4").Activate
ActiveCell.FormulaR1C1 = "=RANK(RC[-1],R4C[-1]:R37C[-1],0)"
Selection.FillDown
Set rngBereich1 = Range("O4:O7")
Set rngBereich2 = Range("O14:O17")
Set rngBereich3 = Range("O24:O27")
Set rngBereich4 = Range("O34:O37")
Set Gesamt = Union(rngBereich1, rngBereich2, rngBereich3, rngBereich4)
Gesamt.Select
Range("O4").Activate
ActiveCell.FormulaR1C1 = "=RANK(RC[-1],R4C[-1]:R37C[-1],0)"
Selection.FillDown
For Each Zelle In Selection
Zelle.Value = Zelle.Value
Next
Columns(14).Clear
For i = 0 To 30 Step 10
For j = 4 To 7
For k = 1 To 33
If i + j <> k Then
If Range("O" & i + j).Value = Range("O" & k).Value Then
If Range("L" & i + j).Value > Range("L" & k).Value Then
Range("O" & i + j).Value = Range("O" & i + j).Value + 1
End If
End If
End If
Next
Next
Next
Set Gesamt = Nothing
Set rngBereich1 = Nothing
Set rngBereich2 = Nothing
Set rngBereich3 = Nothing
Set rngBereich4 = Nothing
Range("O4").Select
Application.ScreenUpdating = True
End Sub
Sub Werte_Loeschen()
Dim rngBereich1 As Range, rngBereich2 As Range, rngBereich3 As Range, rngBereich4 As Range, Gesamt As Range
Set rngBereich1 = Range("O4:O7")
Set rngBereich2 = Range("O14:O17")
Set rngBereich3 = Range("O24:O27")
Set rngBereich4 = Range("O34:O37")
Set Gesamt = Union(rngBereich1, rngBereich2, rngBereich3, rngBereich4)
Gesamt.ClearContents
Range("O4").Select
End Sub
Noch ein paar Knöppe drauf und Makros zuweisen
Gut Holz :-))
Roland