1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
| Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Sortie
Application.EnableEvents = False
If Target.Address = "$B$6" Then Echelon
Sortie:
Application.EnableEvents = True
End Sub
Sub Echelon()
Dim f1 As Worksheet, f2 As Worksheet
Dim Lig As Long, DerLig_f2 As Long, i As Long, j As Long, Anciennete As Long, Col As Long
Dim Grade As String
Dim g As Range
Application.ScreenUpdating = False
Set f1 = Sheets("Simulation")
Set f2 = Sheets("Administratif")
DerLig_f2 = f2.Cells.SpecialCells(xlCellTypeLastCell).Row
Grade = f1.Cells(6, "B")
With f2.Range("A2:Y" & DerLig_f2)
Set g = .Find(Grade, lookat:=xlWhole)
If Not g Is Nothing Then
Col = g.Column
Lig = g.Row
DerLig_f2 = f2.Cells(Lig, Col).End(xlDown).Row
End If
End With
For i = 20 To 22
Anciennete = f1.Cells(i, "H")
If Anciennete < f2.Cells(Lig + 2, Col + 1) Then
f1.Cells(i, "I") = f2.Cells(Lig + 1, Col)
Exit For
End If
For j = Lig + 1 To DerLig_f2
If Anciennete >= f2.Cells(j, Col + 1) And Anciennete <= f2.Cells(j, Col + 2) Then
f1.Cells(i, "I") = f2.Cells(j, Col)
Exit For
End If
Next j
Next i
Set g = Nothing
Set f1 = Nothing
Set f2 = Nothing
End Sub |
Excel VBA - Formules Plusieurs critères
Répondre avec citation
Envoyé par ARTURO83
Je vais aller essayer de la comprendre 
Partager