Dernière ligne si Doublons

Sub Extraction()
Dim MOT1 As String, MOT2 As String, PremAdresse, c, PlageNoms, Zone, i&, pos As Byte
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set PlageNoms = Sheets("Feuil1").Range("A5:F" & Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row)
Set Zone = Sheets("Feuil2").Range("B2:J" & Sheets("Feuil2").Range("J" & Rows.Count).End(xlUp).Row)
MOT1 = "MOT1"
MOT2 = "MOT2"
For i = 1 To PlageNoms.Rows.Count
    With Worksheets(2).Range("B2:B" & Zone.Rows.Count + 1)
        Set c = .Find(PlageNoms(i, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
        If Not c Is Nothing Then
            PremAdresse = c.Address
            Do
            pos = InStr(1, CStr(Sheets("Feuil2").Range("H" & c.Row).Value), MOT1)
                If pos > 0 Then PlageNoms(i, 4) = Sheets("Feuil2").Range("I" & c.Row).Value: PlageNoms(i, 3) = _
                Sheets("Feuil2").Range("J" & c.Row).Value: Exit Do
                Set c = .FindPrevious(c)
            Loop While Not c Is Nothing And c.Address <> PremAdresse
        End If
    End With
Next i
For i = 1 To PlageNoms.Rows.Count
    With Worksheets(2).Range("B2:B" & Zone.Rows.Count + 1)
        Set c = .Find(PlageNoms(i, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
        If Not c Is Nothing Then
            PremAdresse = c.Address
            Do
            pos = InStr(1, CStr(Sheets("Feuil2").Range("H" & c.Row).Value), MOT2)
                If pos > 0 Then PlageNoms(i, 6) = Sheets("Feuil2").Range("I" & c.Row).Value: PlageNoms(i, 5) = _
                Sheets("Feuil2").Range("J" & c.Row).Value: Exit Do
                Set c = .FindPrevious(c)
            Loop While Not c Is Nothing And c.Address <> PremAdresse
        End If
    End With
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Tableau()
Range("C5:F" & Range("A65536").End(xlUp).Row).ClearContents
v = Range("A4:F" & Range("A65536").End(xlUp).Row)
With Sheets("feuil2")
    vData = .UsedRange.SpecialCells(xlCellTypeConstants)
    vNom = .Range("B:B").SpecialCells(xlCellTypeConstants)
End With
For i = LBound(v) + 1 To UBound(v)
    m1 = v(LBound(v), 3)
    m2 = v(LBound(v), 5)
    For j = UBound(vNom) To LBound(vNom) Step -1
        If vNom(j, 1) = v(i, 1) Then
            If Right(vData(j, 1), Len(m1)) = m1 And v(i, 3) = "" Then v(i, 3) = vData(j, 3): v(i, 4) = vData(j, 2)
            If Right(vData(j, 1), Len(m2)) = m2 And v(i, 5) = "" Then v(i, 5) = vData(j, 3): v(i, 6) = vData(j, 2)
            If v(i, 3) <> "" And v(i, 5) <> "" Then Exit For
        End If
    Next j
Next i
Range("A4:F" & Range("A65536").End(xlUp).Row) = v
End Sub

Sub Tableau()
Dim t
t = Time
Range("C5:F" & Range("A65536").End(xlUp).Row).ClearContents
v = Range("A4:F" & Range("A65536").End(xlUp).Row)
With Sheets("feuil2")
    vData = .UsedRange.SpecialCells(xlCellTypeConstants)
    vNom = .Range("B:B").SpecialCells(xlCellTypeConstants)
End With
For i = LBound(v) + 1 To UBound(v)
    m1 = v(LBound(v), 3)
    m2 = v(LBound(v), 5)
    For j = UBound(vData) To LBound(vData) Step -1
        If vNom(j + 1, 1) = v(i, 1) Then
            If Right(vData(j, 1), Len(m1)) = m1 And v(i, 3) = "" Then v(i, 3) = vData(j, 3): v(i, 4) = vData(j, 2)
            If Right(vData(j, 1), Len(m2)) = m2 And v(i, 5) = "" Then v(i, 5) = vData(j, 3): v(i, 6) = vData(j, 2)
            If v(i, 3) <> "" And v(i, 5) <> "" Then Exit For
        End If
    Next j
Next i
Range("A4:F" & Range("A65536").End(xlUp).Row) = v
MsgBox Format(Time - t, "hh:mm:ss")
End Sub