Bienvenue sur les forums conseil & création · S'enregistrer

Se connecter automatiquement

Forums » Tableurs et logiciels de gestion (Money, Excel, Open Office...) » Macro de recherche dans Excel · Envoyer le lien

Par elricou, le 30 Mar 2012, 18:17 Revenir en haut de page Répondre en citant

Bonsoir
si vous aviez une suggestion Wink

j'ai un fichier excel avec une feuille RECHERCHE cette feuille par un mot clé affiche chaque cellule contenant le mot en question contenu dans les feuilles suivantes
J'aimerai afficher une cellule de la ligne contenant le mot recherché, il trouve le mot sur la feuille "P" en F2 et j'aimerai récupérer aussi la cellule A2

Le code se situe sur MODULE 1 :
Sub filtrer()
Dim A, c, reponse As String, s As Byte, i&, j&, k&, l&, Nb&, Pl As Range, DerCel As Variant
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
A = Split(Extractions(Sans_accents(InputBox("Texte ou expression à rechercher")), " +", " ")) 'suite aux conseils avisés de staple
l = 1
For s = 1 To Sheets.Count
If Sheets(s).Name <> "RésultatRecherche" Then
'With Sheets(s)
' Set Pl = Sheets(s).Range("A2").CurrentRegion.Offset(1) _
' .Resize(Sheets(s).Range("A2").CurrentRegion.Rows.Count - 1)
'End With
With Sheets(s)
DerCel = .Cells(.Cells.Find("*", , , , xlByRows, xlPrevious).Row, .Cells.Find("*", , , , xlByColumns, xlPrevious).Column).Address
Set Pl = .Range("A2:" & DerCel)
End With

Dim b(), d()
i = 1
ReDim b(1 To Pl.Cells.Count, 2)
For j = 1 To Pl.Columns.Count
For k = 1 To Pl.Rows.Count
b(i, 0) = Replace(Sans_accents(Pl(k, j)), ",", "")
b(i, 1) = Pl(k, j)
b(i, 2) = Sheets(s).Name & "#" & Pl(k, j).Address
i = i + 1
Next k
Next j

For i = LBound(b) To UBound(b)
c = Split(b(i, 0))
For j = LBound(A) To UBound(A)
For k = LBound(c) To UBound(c)
If A(j) = c(k) Then
Nb = Nb + 1: Exit For
End If
Next k
Next j

If Nb = UBound(A) + 1 Then
ReDim Preserve d(1 To l)
d(l) = b(i, 1) & "#" & b(i, 2)
'd(l, 1) = b(i, 2)
l = l + 1
End If
Nb = 0
Next i
End If
Next s

Dim e()
For i = LBound(d) To UBound(d)
ReDim Preserve e(1 To UBound(d))
e(i) = Split(d(i), "#")
Sheets("RésultatRecherche").Cells(i + 5, 1) = e(i)(0)
Sheets("RésultatRecherche").Cells(i + 5, 1).Hyperlinks.Add Anchor:=Sheets("RésultatRecherche").Cells(i + 5, 1), Address:="", SubAddress:= _
Sheets(e(i)(1)).Name & "!" & e(i)(2), TextToDisplay:=e(i)(0)
Next i
Exit Sub
Erreur:
MsgBox "chaîne de caractère inconnue"
End Sub

Function Sans_accents(Chaine As String) 'http://www.generation-nt.com/reponses/comment-remplacer-caractere-accentue-par-non-accentue-e-mails-entraide-3563901.html
Dim T As String, A As String, b As String
Dim i As Integer, U As String
If Chaine = "" Then Exit Function
T = Chaine
'remplacement des caractères accentués
A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
b = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
For i = 1 To Len(T)
U = InStr(1, A, Mid(T, i, 1), 0)
If U Then Mid(T, i, 1) = Mid(b, U, 1)
Next i
Sans_accents = T
End Function
Function Extractions(Texte As String, MonPattern As String, Optional Remplacement As String, Optional Inverse As Boolean) As String 'par JNP
Dim Match, Matches
If Inverse = False Then
With CreateObject("vbscript.regexp")
.Global = True: .Pattern = MonPattern
Extractions = Trim(.Replace(Texte, Remplacement))
End With
Else
With CreateObject("vbscript.regexp")
.Global = True: .Pattern = Replace(MonPattern, " ?", "")
Set Matches = .Execute(Texte)
For Each Match In Matches
Extractions = Extractions & " " & Match
Next
End With
Extractions = Trim(Extractions)
End If
End Function

si vous aviez une piste ?
Par Horny, le 15 Avr 2012, 19:54 Revenir en haut de page Répondre en citant

Salut,

Je ne suis pas sûr d'avoir exactement compris le problème, mais si DerCel est la cellule que tu recherche (dans ton exemple tu cite F2), au lieu de définir
Code:
DerCel = .Cells(.Cells.Find("*", , , , xlByRows, xlPrevious).Row, .Cells.Find("*", , , , xlByColumns, xlPrevious).Column).Address


pourquoi ne pas récupérer directement la ligne avec

Code:
DerCel = .Cells(.Cells.Find("*", , , , xlByRows, xlPrevious).Row, .Cells.Find("*", , , , xlByColumns, xlPrevious).Column).Row


ce qui permettrait ensuite de récupérer facilement la valeur de A2, soit avec Cells(1,DerCel).Value, soit avec Range("A"&DerCel).value ?


@+++

Forums » Tableurs et logiciels de gestion (Money, Excel, Open Office...) » Macro de recherche dans Excel · Envoyer le lien