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
| Option Explicit
Sub test()
Dim i As Integer, j As Integer, k As Integer
Dim cle As String, CurrString As String
Dim FL1 As Worksheet 'Feuille "Main Thresh"
Dim FL2 As Worksheet 'Feuille "EMR"
Dim c As Range, LigDeb As String
Application.ScreenUpdating = False
'Instanciation des feuilles de calculs concernées (pour simplifier le code à venir)
Set FL1 = Worksheets("Main Thresh")
Set FL2 = Worksheets("EMR")
CurrString = ""
j = 4
Application.ScreenUpdating = False
While FL1.Cells(1, j).Value <> ""
'Comment est fixé 360 ? (***)
For i = 2 To 360
'La clé est constituée des colonnes 1, 2 et 3 d'une même ligne & de la colonne J de la ligne 1
cle = FL1.Cells(i, 1).Value & FL1.Cells(i, 2).Value & FL1.Cells(i, 3).Value & FL1.Cells(1, j).Value
'Recherche de la valeur de FL1.Cells(i,1) dans la colonne F de FL2
With FL2.Range("F2:F" & Split(FL2.UsedRange.Address, "$")(4))
Set c = .Find(FL1.Cells(i, 1).Value)
If Not c Is Nothing Then
LigDeb = c.Address
Do
k = c.Row
CurrString = FL2.Cells(k, 6).Value & FL2.Cells(k, 7).Value & FL2.Cells(k, 8).Value & FL2.Cells(k, 9).Value & FL2.Cells(k, 10).Value & FL2.Cells(k, 11).Value & FL2.Cells(k, 12).Value & FL2.Cells(k, 13).Value & FL2.Cells(k, 14).Value & FL2.Cells(k, 15).Value & FL2.Cells(k, 16).Value & FL2.Cells(k, 17).Value
If CurrString = cle Then FL1.Cells(i, j) = FL2.Cells(k, 18)
'Cette recherche ne se poursuit que si FL1.Cells(i, 1) a été trouvé
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> LigDeb
End If
End With
Next i
'Ajoute une ligne à FL1
j = j + 1
Wend
Application.ScreenUpdating = True
End Sub |
