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
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