Macro find - resultat pas dans l'ordre du fichier souce

Bonjour à tous,

je viens encore vous embêter...

J'ai fait une macro pour chercher dans une base de données des informations suivant un critère et ramener dans un 2em fichier le résultat

le code marche bien sauf que l'ordre du résultat n'est pas identique a celui de la base de données. c'est peut être mon bouclage qui n'est pas bon?! mais vu mon pauvre niveau je ne trouve pas...

La 1er ligne de la recherche trouvée est bonne

la 2em ligne ramène la dernière ligne du fichier source

la 3em ligne ramène la avant-dernière ligne du fichier source

voici le bout code : (il m'est difficile de passer le fichier complet, y'a des liens réseau partout...et des donnée du travail que je peux pas communiquer dsl)

'******************* valeur a rechercher pour remplissage **************
Windows(NoDM & "_" & Format(Date, "dd-mm-yy") & ".xlsm").Activate ' fichier vierge créé plus haut, fichier dans lequel on va "coller" les infos recherchées par le find plus bas
Range("a2").Select
ActiveCell.FormulaR1C1 = Chr(39) & NoDM  ' valeur recherchée par le find plus bas

'************************* remplissage ***********************
Dim f As Range, c As Variant
Application.ScreenUpdating = False ' deja fait plus haut
Workbooks(NoDM & "_" & Format(Date, "dd-mm-yy") & ".xlsm").Sheets(NoDM).Activate ' fichier vierge créé plus haut
With Workbooks(adresse4).Sheets("DM Ref") ' fichier source dans lequel on vient chercher et copier les info suivant critere "N°DM"
For Each c In .Range("a3:a" & .Range("a65000").End(xlUp).Row)
Set f = Workbooks(NoDM & "_" & Format(Date, "dd-mm-yy") & ".xlsm").Sheets(NoDM).Range("a2:a" & Range("a65000").End(xlUp).Row).Find(c, LookIn:=xlValues, LookAt:=xlWhole)
If Not f Is Nothing Then
Rows(f.Row + 1).Insert Shift:=xlDown
Cells(f.Row + 1, 1) = Workbooks(adresse4).Sheets("DM Ref").Range("a" & c.Row) 'n°dm
Cells(f.Row + 1, 2) = Workbooks(adresse4).Sheets("DM Ref").Range("b" & c.Row) 'metier
Cells(f.Row + 1, 3) = Workbooks(adresse4).Sheets("DM Ref").Range("c" & c.Row) 'FO
Cells(f.Row + 1, 4) = Workbooks(adresse4).Sheets("DM Ref").Range("d" & c.Row) 'FPO

End If: Next c
End With

Merci bcp de votre aide !

Bonjour,

rien ne t'empêche d'en faire un extrait !

le problème vient d'ici :

            Rows(f.Row + 1).Insert Shift:=xlDown

puisque tu insères une ligne en repoussant vers le bas les cellules déjà trouvées : elles sont bien trouvées dans l'ordre, mais c'est toi qui les poussent vers le bas !

Bonjour, salut Steelson,

J'ai eu du mal à comprendre la logique, je me suis donc permis de modifier le code pour faire autrement :

Sub Test()

'NOTE : pas de déclaration en cours de macro, toutes les variables sont à déclarer en début de macro
Dim f As Range, DerLig As Long, Lig As Long, Lig2 As Long
Dim adresse4 As String, NoDM As String
Dim WSS As Sheet, WSC As Sheet

'Remplissage des variables
adresse4 = "Truc"
NoDM = "b"
WSS = Workbooks(adresse4).Sheets("DM Ref")
WSC = Workbooks(NoDM & "_" & Format(Date, "dd-mm-yy") & ".xlsm").Sheets(NoDM)

'Recherche des correspondances (POSSIBILITE 1)
Application.ScreenUpdating = False
With WSS ' fichier source dans lequel on vient chercher et copier les info suivant critere "N°DM"
    DerLig = .Range("A65000").End(xlUp).Row
    For Lig = 2 To DerLig
        If .Cells(Lig, 1) = NoDM Then
            Lig2 = Lig2 + 1
            WSC.Cells(Lig2, 1) = WSS.Range("A" & Lig) 'n°dm
            WSC.Cells(Lig2, 2) = WSS.Range("B" & Lig) 'metier
            WSC.Cells(Lig2, 3) = WSS.Range("C" & Lig) 'FO
            WSC.Cells(Lig2, 4) = WSS.Range("D" & Lig) 'FPO
        End If
    Next Lig
End With
'Fin POSSIBILITE 1

End Sub

POSSIBILITE 1 est remplaçable par :

'Recherche des correspondances (POSSIBILITE 2)
Application.ScreenUpdating = False
With WSS ' fichier source dans lequel on vient chercher et copier les info suivant critere "N°DM"
    DerLig = .Range("A65000").End(xlUp).Row
    NbRes = Application.CountIf(WSS.Range("A2:A" & DerLig), NoDM)
    For Lig = 1 To NbRes
        Set f = WSC.Range("A" & LigRes + 1 & ":A" & DerLig).Find(NoDM, LookIn:=xlValues, LookAt:=xlWhole)
        If Not f Is Nothing Then
            LigRes = f.Row
            Lig2 = Lig2 + 1
            WSC.Cells(Lig2, 1) = WSS.Range("A" & LigRes) 'n°dm
            WSC.Cells(Lig2, 2) = WSS.Range("B" & LigRes) 'metier
            WSC.Cells(Lig2, 3) = WSS.Range("C" & LigRes) 'FO
            WSC.Cells(Lig2, 4) = WSS.Range("D" & LigRes) 'FPO
        End If
    Next Lig
End With

NOTE : les déclarations de variables sont à modifier en conséquence.

Bonjour Messieurs,

Merci pour vos retours,

Steelson, j'ai essayé de virer l'insert et de le remplacer par un offset (1,0) mais ça marche pas...

Pedro22

j'ai testé les deux codes et j'ai un pb de compilation :

ça met en surbrillance dim Wss as Sheet et me message d'erreur dit : Type défini par l'utilisateur non défini...une idée?

Cdt

SB

Pedro22

j'ai testé les deux codes et j'ai un pb de compilation :

ça met en surbrillance dim Wss as Sheet et me message d'erreur dit : Type défini par l'utilisateur non défini...une idée?

Essaye en remplaçant les "Sheet" par des "Worksheet" et "Sheets" par des des "Worksheets".

Fais une copie très simplifiée de ton fichier, ce sera plus rapide et plus sûr ... j'avais commencé à en faire une mais par "économie de temps" je n'ai pas poursuivi.

mes hommages Pedro !

Bonjour Messieurs,

Merci pour vos retours, j'ai changé les sheet par worksheets.... et rajouté des Set devant la déclaration WSS et WSC.

et ça marche impeccable

Merci beaucoup pour votre aide.

Cdt

SB

Dim WSS As Worksheet, WSC As Worksheet
'....

Set WSS = Workbooks(adresse4).Sheets("DM Ref")
Set WSC = Workbooks(NoDM & "_" & Format(Date, "dd-mm-yy") & ".xlsm").Worksheets(NoDM)

'
'Recherche des correspondances (POSSIBILITE 1)
Application.ScreenUpdating = False
With WSS ' fichier source dans lequel on vient chercher et copier les info suivant critere "N°DM"
    DerLig = .Range("A65000").End(xlUp).Row
    For Lig = 2 To DerLig
        If .Cells(Lig, 1) = NoDM Then
            Lig2 = Lig2 + 1
            WSC.Cells(Lig2, 1) = WSS.Range("A" & Lig) 'n°dm
            WSC.Cells(Lig2, 2) = WSS.Range("B" & Lig) 'metier

        End If
    Next Lig
End With
Rechercher des sujets similaires à "macro find resultat pas ordre fichier souce"