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 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
| Sub test()
Dim i As Integer, j As Integer, k As Integer
Dim cle As String, CurrString As String
Dim FL1 As Worksheet 'Feuille "sheet3"
Dim FL2 As Worksheet 'Feuille "sheet1"
Dim c As Range, LigDeb As String
Dim Dtype As String
Application.ScreenUpdating = False
'Instanciation des feuilles de calculs concernées (pour simplifier le code à venir)
Set FL1 = Worksheets("sheet3")
Set FL2 = Worksheets("sheet1")
CurrString = ""
j = 4
Application.ScreenUpdating = False
While FL1.Cells(1, j).Value <> ""
For i = 2 To 360
'La clé est constituée de la colonne 3 d'une même ligne & de la colonne J de la ligne 1
cle = FL1.Cells(i, 3).Value & FL1.Cells(1, j).Value
'Recherche de la valeur de FL1.Cells(i,3) dans la colonne F de FL2
With FL2.Range("Y2:Y" & Split(FL2.UsedRange.Address, "$")(4))
Set c = .Find(FL1.Cells(i, 3).Value)
If Not c Is Nothing Then
LigDeb = c.Address
Do
k = c.Row
CurrString = FL2.Cells(k, 25).Value & FL2.Cells(k, 26).Value
If CurrString = cle Then
FL1.Cells(i, j) = FL2.Cells(k, 18)
'Je récupère le type qui est en colonne C
Dtype = FL2.Cells(k, 3)
With FL1.Cells(i, j).Font
Select Case Dtype
Case "type1"
.Bold = True
.ColorIndex = xlAutomatic
Case "type2"
.Bold = False
.ColorIndex = 3
Case "type3"
.Bold = False
.ColorIndex = 5
Case Else
.Bold = False
.ColorIndex = xlAutomatic
End Select
End With
End If
'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 |
Partager