Dim t 'mémorise la variable
Function ProxiInf(limit!) As Byte
Dim i As Byte, maxi!
For i = 1 To 20
If t(1, i) <> "" Then If t(1, i) < limit Then If t(1, i) > maxi Then maxi = t(1, i): ProxiInf = i
Next
If ProxiInf Then t(1, ProxiInf) = ""
End Function
Function ProxiSup(limit!) As Byte
Dim mini!, i As Byte
mini = 1000000
For i = 1 To 20
If t(1, i) >= limit Then If t(1, i) < mini Then mini = t(1, i): ProxiSup = i
Next
If ProxiSup Then t(1, ProxiSup) = ""
End Function
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "Cote*" Then Exit Sub 'critère
Dim limit1!, limit2!, c As Range, transfer As Boolean, resu As Range, i As Byte, n As Byte
limit1 = 10.1 'à adapter
limit2 = 3.5 'à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.Goto Sh.[A1], True 'cadrage
For Each c In Sh.UsedRange.Columns(2).Cells
If c = "Cotes" Then
transfer = c(2) = "N°" 'teste la ligne
If transfer Then Set resu = c.EntireRow.Find("C*", c, xlValues, xlWhole): If Not resu Like "C#*" Then transfer = False
If transfer Then Set resu = resu(1, 2).Resize(2, 6): resu = "" 'RAZ
With c(1, 2).Resize(, 20)
.Interior.Color = RGB(204, 255, 255) 'RAZ
.Font.Color = RGB(128, 0, 128) 'RAZ
t = .Value
End With
For n = 1 To 2
i = ProxiInf(limit1)
If i Then
c(1, i + 1).Interior.Color = RGB(91, 155, 213) 'bleu
c(1, i + 1).Font.Color = vbWhite
If transfer Then resu(1, n) = c(2, i + 1): resu(2, n) = c(1, i + 1)
End If
Next n
For n = 1 To 2
i = ProxiSup(limit1)
If i Then
c(1, i + 1).Interior.Color = RGB(51, 153, 102) 'vert
c(1, i + 1).Font.Color = vbWhite
If transfer Then resu(1, n + 2) = c(2, i + 1): resu(2, n + 2) = c(1, i + 1)
End If
Next n
For n = 1 To 2
i = ProxiSup(limit2)
If i Then
c(1, i + 1).Interior.Color = RGB(192, 0, 0) 'rouge
c(1, i + 1).Font.Color = vbWhite
If transfer Then resu(1, n + 4) = c(2, i + 1): resu(2, n + 4) = c(1, i + 1)
End If
Next n
End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub
