Dernière ligne si Doublons

[Chris401]

Bonsoir

Quelqu'un peut-il me donner le code pour trouver la dernière ligne occupée par un mot

Feuille 1 : Une liste de noms uniques de A5 à A derligne
Feuille 2 : Une liste de noms pouvant se répéter de B2 à B derligne

Il n'est pas obligatoire de trouver les noms de Feuille 1 dans Feuille 2 (et vice-versa)

Pour chaque cellule de Feuille 1 :
- si le nom ne se trouve pas dans Feuille 2 alors la cellule Cx de feuille 1 est vide
- si le nom se trouve dans Feuille 2 alors la cellule Cx de feuille 1 = la cellule Hx de feuille 2 - MAIS x doit être la dernière ligne s'il y a doublons (ou plus)

Voir fichier

Merci de votre aide
Cordialement
Chris

 

[david84]

Re : Dernière ligne si Doublons

Re
même code un peu simplifié :

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

A+

 

[Habitude]

Re : Dernière ligne si Doublons

Donc la suite...

Dans le fichier joint j'ai mis une fonction par tableau
très performante dans le cas ou dans feuil1, le tableau est statique
Le tableau va quand même faire une boucle de 900*~2000

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

ET une fonction avec 3 modules de classes.
cette fontion pourrait permettre de créer le tableau dynamiquement dans feuil1
Pas tres bonne pour des tableaux statique.

Cette derniere va boucler seulement 2000 fois et classer les informations (avec boucle relative)
Ensuite elle va boucle pour charger le tableau en recherchant les informations indexé.
Le chargement par recherche est plus ou moins efficace.

 

[Chris401]

Re : Dernière ligne si Doublons

Re

Je te remercie de tout le temps que tu passes à solutionner ma demande.

J'ai fait les tests - Les durées d'exécution sont :

Fonction = 1:42
TEST2 = 0:07
EXECUTION = 0:06
TABLEAU = 0:01 (immédiat)

Cependant, TABLEAU ne retourne pas les bonnes valeurs.

Voir fichier

Chris

 

[david84]

Re : Dernière ligne si Doublons

Re
As-tu testé le code que je t'ai proposé au message #16 ?
A+

 

[Habitude]

Re : Dernière ligne si Doublons

Dans le feui2 tu as un entete de colonne en B1 et rien dans H1, I1 et J1
ca crée donc un décalage entre le tableau data et le tableau nom
Met des entete et c'est réglé

Sinon tu peux mettre ceci a la place
2 lignes de code a changer

For j = UBound(vData) To LBound(vData) Step -1

If vNom(j + 1, 1) = v(i, 1) Then

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

 

[Chris401]

Re : Dernière ligne si Doublons

Re

David : Oui, j'ai testé ton code - Il est dans le fichier que j'ai joint (je me suis trompé sur le nom dans mon message précédent - j'ai mis EXECUTION à la place de EXTRACTION) - Je t'en remercie.

Habitude: j'ai mis des titres et j'ai ce message :

"l'indice n'appartient pas à la sélection ..." et cette partie du code est surlignée :
If Right(vData(j, 1), Len(m1)) = m1 And v(i, 3) = "" Then

J'ai pris le nouveau code, et avec lui je n'ai plus aucun résultat.

Aurais-tu la gentillesse de me renvoyer le fichier avec la correction STP ?

Cordialement

EDIT : J'ai fini par trouver mon erreur - J'avais DATE en Feuille 1 et DATES en feuille 2
Merci à tous pour votre aide