J'ai une petite macro qui malheureusement n'a pas son effet voulu.
J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de
colonne)
J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en
reprenant mes 1200 noms de la feuille 2 et en les complétant avec la
ligne entière quand il existe une correspondance avec le tableau de
donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot
de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça
serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1)
Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vNomFeuille
Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then
Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1)
Nvligne = Nvligne + 1
End If
Next c
Set Cherch = Nothing
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
isabelle
bonjour Sylian,
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
bonjour Sylian,
c'est possible de faire cela avec une formule,
mettre cette formule sur la feuille fl2 en cellule B1
et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu.
J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de
colonne)
J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en
reprenant mes 1200 noms de la feuille 2 et en les complétant avec la
ligne entière quand il existe une correspondance avec le tableau de
donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot
de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça
serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1)
Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vNomFeuille
Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then
Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1)
Nvligne = Nvligne + 1
End If
Next c
Set Cherch = Nothing
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
Sylian
Merci de l'astuce Isabelle. J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de ligne à extraire et comparer. la modification d'une cellule demande un recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
Merci de l'astuce Isabelle.
J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de
ligne à extraire et comparer. la modification d'une cellule demande un
recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule,
mettre cette formule sur la feuille fl2 en cellule B1
et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu.
J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de
colonne)
J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en
reprenant mes 1200 noms de la feuille 2 et en les complétant avec la
ligne entière quand il existe une correspondance avec le tableau de
donnée en feuille 1. Petite info supplémentaire : je cherche chaque
mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB
(fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1)
Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vNomFeuille
Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then
Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1)
Nvligne = Nvligne + 1
End If
Next c
Set Cherch = Nothing
Merci de l'astuce Isabelle. J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de ligne à extraire et comparer. la modification d'une cellule demande un recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
isabelle
bonjour Sylian,
voilà :
Sub Macro1() For i = 1 To Sheets("fl2").Range("A65536").End(xlUp).Row On Error Resume Next Set trouve = Range("A" & Application.Match(Sheets("fl2").Range("A" & i), Sheets("fl1").Range("A:A"), 0)) 'test = trouve.Row If Not trouve Is Nothing Then For y = 2 To 10 Sheets("fl2").Cells(i, y) = Sheets("fl1").Cells(trouve.Row, y) Next End If Next End Sub
isabelle
Merci de l'astuce Isabelle. J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de ligne à extraire et comparer. la modification d'une cellule demande un recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
bonjour Sylian,
voilà :
Sub Macro1()
For i = 1 To Sheets("fl2").Range("A65536").End(xlUp).Row
On Error Resume Next
Set trouve = Range("A" & Application.Match(Sheets("fl2").Range("A" & i), Sheets("fl1").Range("A:A"), 0))
'test = trouve.Row
If Not trouve Is Nothing Then
For y = 2 To 10
Sheets("fl2").Cells(i, y) = Sheets("fl1").Cells(trouve.Row, y)
Next
End If
Next
End Sub
isabelle
Merci de l'astuce Isabelle.
J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de
ligne à extraire et comparer. la modification d'une cellule demande un
recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule,
mettre cette formule sur la feuille fl2 en cellule B1
et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu.
J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de
colonne)
J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en
reprenant mes 1200 noms de la feuille 2 et en les complétant avec la
ligne entière quand il existe une correspondance avec le tableau de
donnée en feuille 1. Petite info supplémentaire : je cherche chaque
mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB
(fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1)
Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vNomFeuille
Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then
Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1)
Nvligne = Nvligne + 1
End If
Next c
Set Cherch = Nothing
Sub Macro1() For i = 1 To Sheets("fl2").Range("A65536").End(xlUp).Row On Error Resume Next Set trouve = Range("A" & Application.Match(Sheets("fl2").Range("A" & i), Sheets("fl1").Range("A:A"), 0)) 'test = trouve.Row If Not trouve Is Nothing Then For y = 2 To 10 Sheets("fl2").Cells(i, y) = Sheets("fl1").Cells(trouve.Row, y) Next End If Next End Sub
isabelle
Merci de l'astuce Isabelle. J'y avais pensé également à l'aide d'un ChercheV mais il y a trop de ligne à extraire et comparer. la modification d'une cellule demande un recalcule long et fastidieux. Je préfère m'orienter vers une Macro.
Une autre idée ?
bonjour Sylian,
c'est possible de faire cela avec une formule, mettre cette formule sur la feuille fl2 en cellule B1 et recopier à droite
=INDEX(fl1!B:B;EQUIV($A1;fl1!$A:$A;0))
isabelle
Bonjour les pros !
J'ai une petite macro qui malheureusement n'a pas son effet voulu. J'ai une feuille 1 (fl1) avec près de 19000 lignes (sur une 20aine de colonne) J'ai une feuille 2 avec une liste d'environ 1200 nom en colonne A
Le but de ma macro est de générer un tableau en feuille3 (fl2) en reprenant mes 1200 noms de la feuille 2 et en les complétant avec la ligne entière quand il existe une correspondance avec le tableau de donnée en feuille 1. Petite info supplémentaire : je cherche chaque mot de la feuille2/colonneA (sheets(2))dans la feuille1/colonneB (fl1)(ça serait trop simple sinon lol)
Voici ma routine qui plante à mon grand désespoir :
-----------------------------
Sub correspondance()
Set fl1 = Sheets(1) Nvligne = 1
' insere une nouvelle feuille de réslutat
vNomFeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vNomFeuille Set fl2 = Worksheets(vNomFeuille)
'Cherche et extrait
Application.ScreenUpdating = False
For Each c In Sheets(2).Range("A1:A" & [A20000].End(xlUp).Row)
Set Cherch = fl1.Range("B5:B" & [B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then Cherch.EntireRow.Copy fl2.Cells(nvLigne, 1) Nvligne = Nvligne + 1 End If Next c Set Cherch = Nothing
End Sub
-----------------------------
Merci d'avance pour le coup de pouce !
Fredo P
Sub correspondance()
Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Sub correspondance()
Set fl1 = Feuil1
Nvligne = 1
' insere une nouvelle feuille de réslutat
vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
If IsError(Sheets(vnomfeuille).Activate) Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vnomfeuille
End If
'Cherche et extrait
Set fl2 = Worksheets(vnomfeuille)
Application.ScreenUpdating = False
For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row)
If c <> "" Then
Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then ' c.value
Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1)
Nvligne = Nvligne + 1
End If
End If
Next c
Set Cherch = Nothing
Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Sylian
Re-bonjour
Merci à toi Fredo et Isabelle mais aucune de vos deux autres solutions ne fonctionne. L'une me génère des messages d"erreur et l'autre ne recopie rien du tout. J'ai essayé de les bidouiller mais sans succès :( (je suis trop mauvais)
Voici un exemple de ce que je voudrais faire : http://cjoint.com/?fFsCV5h1Np En considérant que la feuille 3 est le résultat de la macro.
Merci beaucoup d'avance !
Sub correspondance()
Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Re-bonjour
Merci à toi Fredo et Isabelle mais aucune de vos deux autres solutions
ne fonctionne. L'une me génère des messages d"erreur et l'autre ne
recopie rien du tout. J'ai essayé de les bidouiller mais sans succès :(
(je suis trop mauvais)
Voici un exemple de ce que je voudrais faire :
http://cjoint.com/?fFsCV5h1Np
En considérant que la feuille 3 est le résultat de la macro.
Merci beaucoup d'avance !
Sub correspondance()
Set fl1 = Feuil1
Nvligne = 1
' insere une nouvelle feuille de réslutat
vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
If IsError(Sheets(vnomfeuille).Activate) Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vnomfeuille
End If
'Cherche et extrait
Set fl2 = Worksheets(vnomfeuille)
Application.ScreenUpdating = False
For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row)
If c <> "" Then
Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then ' c.value
Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1)
Nvligne = Nvligne + 1
End If
End If
Next c
Set Cherch = Nothing
Merci à toi Fredo et Isabelle mais aucune de vos deux autres solutions ne fonctionne. L'une me génère des messages d"erreur et l'autre ne recopie rien du tout. J'ai essayé de les bidouiller mais sans succès :( (je suis trop mauvais)
Voici un exemple de ce que je voudrais faire : http://cjoint.com/?fFsCV5h1Np En considérant que la feuille 3 est le résultat de la macro.
Merci beaucoup d'avance !
Sub correspondance()
Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In fl2.Range("A1:A" & [A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Fredo P
Ça doit convenir. http://cjoint.com/?fFwrFU4cBB Sub correspondance() Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$ On Error Resume Next Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Ça doit convenir.
http://cjoint.com/?fFwrFU4cBB
Sub correspondance()
Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$
On Error Resume Next
Set fl1 = Feuil1
Nvligne = 1
' insere une nouvelle feuille de réslutat
vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
If IsError(Sheets(vnomfeuille).Activate) Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vnomfeuille
End If
'Cherche et extrait
Set fl2 = Worksheets(vnomfeuille)
Application.ScreenUpdating = False
For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row)
If c <> "" Then
Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then ' c.value
Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1)
Nvligne = Nvligne + 1
End If
End If
Next c
Set Cherch = Nothing
Ça doit convenir. http://cjoint.com/?fFwrFU4cBB Sub correspondance() Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$ On Error Resume Next Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Sylian
Ça doit convenir. http://cjoint.com/?fFwrFU4cBB Sub correspondance() Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$ On Error Resume Next Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Mille mercis Fredo ! J'ai adapté ta formule pour mes feuilles et données persos et après un peu de travail : ça marche !!! Merci pour l'aide, cela va épargner de longues heures de recherche et de copier/coller à tout va.
@bientôt
Sylian
Ça doit convenir.
http://cjoint.com/?fFwrFU4cBB
Sub correspondance()
Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$
On Error Resume Next
Set fl1 = Feuil1
Nvligne = 1
' insere une nouvelle feuille de réslutat
vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer"))
If IsError(Sheets(vnomfeuille).Activate) Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vnomfeuille
End If
'Cherche et extrait
Set fl2 = Worksheets(vnomfeuille)
Application.ScreenUpdating = False
For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row)
If c <> "" Then
Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c,
LookIn:=xlValues, LookAt:=xlWhole)
If Not Cherch Is Nothing Then ' c.value
Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1)
Nvligne = Nvligne + 1
End If
End If
Next c
Set Cherch = Nothing
End Sub
Fredo P.
Mille mercis Fredo !
J'ai adapté ta formule pour mes feuilles et données persos et après un
peu de travail : ça marche !!!
Merci pour l'aide, cela va épargner de longues heures de recherche et de
copier/coller à tout va.
Ça doit convenir. http://cjoint.com/?fFwrFU4cBB Sub correspondance() Dim fl1, Cherch As Range, fl2, c As Object, Nvligne&, vnomfeuille$ On Error Resume Next Set fl1 = Feuil1 Nvligne = 1 ' insere une nouvelle feuille de réslutat vnomfeuille = Trim(InputBox("Nom de la nouvelle feuille à intégrer")) If IsError(Sheets(vnomfeuille).Activate) Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = vnomfeuille End If 'Cherche et extrait Set fl2 = Worksheets(vnomfeuille) Application.ScreenUpdating = False For Each c In Feuil2.Range("A1:A" & Feuil2.[A20000].End(xlUp).Row) If c <> "" Then Set Cherch = fl1.Range("B1:B" & fl1.[B20000].End(xlUp).Row).Find(What:=c, LookIn:=xlValues, LookAt:=xlWhole) If Not Cherch Is Nothing Then ' c.value Cherch.EntireRow.Copy fl2.Cells(Nvligne, 1) Nvligne = Nvligne + 1 End If End If Next c Set Cherch = Nothing
End Sub
Fredo P.
Mille mercis Fredo ! J'ai adapté ta formule pour mes feuilles et données persos et après un peu de travail : ça marche !!! Merci pour l'aide, cela va épargner de longues heures de recherche et de copier/coller à tout va.
