TOTOEXCEL2019
XLDnaute Nouveau
Bonjour,
Je souhaiterais faire une macro vba qui recherche un mot clef dans une feuille et extrait les lignes rattachées à ce mot clef dans une nouvelle feuille Excel.
J'ai trouvé une macro assez proche que je joins, elle permet de faire l'opération mais uniquement pour une recherche de critère dans une colonne spécifique (hors je souhaiterais faire cette recherche de critère dans le tableau complet de la Feuil1).
En d'autre termes : si dans le tableau il y a le critère recherché (quelque soit la colonne de recherche) alors afficher dans une nouvelle feuille les lignes correspondantes.
Voici le code à améliorer :
Sub ExtraitVersAutreFeuille()
critere = InputBox("Critere?")
If critere = "" Then Exit Sub
[A1].AutoFilter Field:=5, Criteria1:="*" & critere & "*"
Application.DisplayAlerts = False
On Error Resume Next
Sheets(critere).Delete
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = critere
Sheets("Feuil1").Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy [A1]
Cells.EntireColumn.AutoFit
Sheets("Feuil1").ShowAllData
End Sub
Merci par avance.
Je souhaiterais faire une macro vba qui recherche un mot clef dans une feuille et extrait les lignes rattachées à ce mot clef dans une nouvelle feuille Excel.
J'ai trouvé une macro assez proche que je joins, elle permet de faire l'opération mais uniquement pour une recherche de critère dans une colonne spécifique (hors je souhaiterais faire cette recherche de critère dans le tableau complet de la Feuil1).
En d'autre termes : si dans le tableau il y a le critère recherché (quelque soit la colonne de recherche) alors afficher dans une nouvelle feuille les lignes correspondantes.
Voici le code à améliorer :
Sub ExtraitVersAutreFeuille()
critere = InputBox("Critere?")
If critere = "" Then Exit Sub
[A1].AutoFilter Field:=5, Criteria1:="*" & critere & "*"
Application.DisplayAlerts = False
On Error Resume Next
Sheets(critere).Delete
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = critere
Sheets("Feuil1").Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy [A1]
Cells.EntireColumn.AutoFit
Sheets("Feuil1").ShowAllData
End Sub
Merci par avance.