Résolu Macro recherche et copie sur une nouvelle feuille

[massekito]

bonjour
je voudrais de l'aide si possible. Je n'y connais absolument rien en macro et j'aimerai si possible en faire une qui dans un fichier excel recherche un mot et copie toute les ligne contenant ce mot sur une nouvelle feuille. en gardant bien sur la mise en page et eventuellement les liens hypertexte.
Puis dans un second temps une recherche qui pourra se faire avec 2 mots ou plus (sur des cases differentes)

Voici ma macro:
Le probléme de cette macro c'est qu'elle recherche independament les mots clé et que lorsqu'elle copie les lignes correspondantes sur une nouvelle feuille elle ne garde pas la mose en page.

Option Compare Text
Sub PegaseDebuggerSearch()
Dim WB As Workbook
Dim S As Worksheet
Dim rep
Dim R As Range
Dim Titres
Dim var
Dim dep&
Dim g&
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim A$
Dim B$()
On Error GoTo Erreur
Titres = Array("PEGASE keyword entered", "File", "range Number", "Reference", "Problem", "Base", "Date", "Keyword #1", "Keyword #2", "Keyword #3", "Keyword #4")
rep = Application.InputBox( _
"insert your keyword" & vbCrLf & vbCrLf & _
"if more than a word insert a space between each of them")
If rep = False Or rep = "" Then Exit Sub
A$ = LCase(rep)
Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
Do Until Right(A$, 1) <> " " And Right(A$, 1) <> Space(1)
A$ = Mid(A$, 1, Len(A$) - 1)
Loop
If InStr(1, A$, " ") = 0 Then
ReDim B$(1 To 1)
B$(1) = A$
Else
Do Until A$ = ""
If Right(A$, 1) <> " " Then A$ = A$ & " "
i& = i& + 1
ReDim Preserve B$(1 To i&)
B$(i&) = Mid(A$, 1, InStr(1, A$, " ") - 1)
A$ = Trim(Mid(A$, Len(B$(i&)) + 2))
Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
B$(i&) = Trim(B$(i&))
Loop
End If
Set WB = ActiveWorkbook
For h& = 1 To WB.Worksheets.Count
Set S = WB.Worksheets(h&)
Set R = S.UsedRange
dep& = R.Row
var = R
If R.Columns.Count > 253 Then
MsgBox "file''" & S.Name & _
"'' can't be treated because more than 253 row"
Else
If Not IsEmpty(var) Then
For g& = 1 To UBound(B$)
For i& = 1 To UBound(var, 1)
For j& = 1 To UBound(var, 2)
A$ = LCase(Trim(var(i&, j&)))
If InStr(1, A$, B$(g&)) > 0 Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 253, 1 To cpt&)
T(1, cpt&) = B$(g&)
T(2, cpt&) = S.Name
T(3, cpt&) = i& + dep& - 1
For k& = 1 To UBound(var, 2)
T(k& + 3, cpt&) = var(i&, k&)
Next k&
Exit For
End If
Next j&
Next i&
Next g&
End If
End If
Next h&
If cpt& = 0 Then
A$ = ""
For i& = 1 To UBound(B$)
A$ = A$ & vbCrLf & B$(i&)
Next i&
MsgBox "no result (verify the spelling)"
Exit Sub
Else
Application.ScreenUpdating = False
Set S = Sheets.Add(before:=ActiveSheet)
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(Titres) + 1))
R = Titres
R.HorizontalAlignment = xlCenter
R.Font.Bold = True
R.Interior.ColorIndex = 40
S.Cells.Columns.AutoFit
End If
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Error : " & Err.Number & vbCrLf & Err.Description
End Sub


Merci d'avance,
Kito

 

[zeb]

Moderator dixit : Merci de lire, respecter et appliquer le règlement.
Présente ton code mieux que ça : utilise la balise

 

[massekito]

[cpp]Option Compare Text
Sub PegaseDebuggerSearch()
Dim WB As Workbook
Dim S As Worksheet
Dim rep
Dim R As Range
Dim Titres
Dim var
Dim dep&
Dim g&
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim A$
Dim B$()
On Error GoTo Erreur
Titres = Array("PEGASE keyword entered", "File", "range Number", "Reference", "Problem", "Base", "Date", "Keyword #1", "Keyword #2", "Keyword #3", "Keyword #4" )
rep = Application.InputBox( _
"insert your keyword" & vbCrLf & vbCrLf & _
"if more than a word insert a space between each of them" )
If rep = False Or rep = "" Then Exit Sub
A$ = LCase(rep)
Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
Do Until Right(A$, 1) <> " " And Right(A$, 1) <> Space(1)
A$ = Mid(A$, 1, Len(A$) - 1)
Loop
If InStr(1, A$, " " ) = 0 Then
ReDim B$(1 To 1)
B$(1) = A$
Else
Do Until A$ = ""
If Right(A$, 1) <> " " Then A$ = A$ & " "
i& = i& + 1
ReDim Preserve B$(1 To i& )
B$(i& ) = Mid(A$, 1, InStr(1, A$, " " ) - 1)
A$ = Trim(Mid(A$, Len(B$(i& )) + 2))
Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
B$(i& ) = Trim(B$(i& ))
Loop
End If
Set WB = ActiveWorkbook
For h& = 1 To WB.Worksheets.Count
Set S = WB.Worksheets(h& )
Set R = S.UsedRange
dep& = R.Row
var = R
If R.Columns.Count > 253 Then
MsgBox "file''" & S.Name & _
"'' can't be treated because more than 253 row"
Else
If Not IsEmpty(var) Then
For g& = 1 To UBound(B$)
For i& = 1 To UBound(var, 1)
For j& = 1 To UBound(var, 2)
A$ = LCase(Trim(var(i&, j& )))
If InStr(1, A$, B$(g& )) > 0 Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 253, 1 To cpt& )
T(1, cpt& ) = B$(g& )
T(2, cpt& ) = S.Name
T(3, cpt& ) = i& + dep& - 1
For k& = 1 To UBound(var, 2)
T(k& + 3, cpt& ) = var(i&, k& )
Next k&
Exit For
End If
Next j&
Next i&
Next g&
End If
End If
Next h&
If cpt& = 0 Then
A$ = ""
For i& = 1 To UBound(B$)
A$ = A$ & vbCrLf & B$(i& )
Next i&
MsgBox "no result (verify the spelling)"
Exit Sub
Else
Application.ScreenUpdating = False
Set S = Sheets.Add(before:=ActiveSheet)
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(Titres) + 1))
R = Titres
R.HorizontalAlignment = xlCenter
R.Font.Bold = True
R.Interior.ColorIndex = 40
S.Cells.Columns.AutoFit
End If
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Error : " & Err.Number & vbCrLf & Err.Description
End Sub [/cpp]

je crois que là ca passe no?

 

[zeb]

Salut,

Euh... oui et non....
Tu viens de permettre à ton message d'être pris en compte, c'est déjà pas mal.
Mais je t'invite très fortement à t'intéresser à l'

Vous devez être connecté pour voir les liens.

.
Cependant que tu découvres cette présentation - et que tu modifieras ton message pour la prendre en compte, en parallèle, je m'intéresse à ton problème.

Par ailleurs, tu aurais pu modifier ton premier message plutôt que de tout réécrire.

 

[massekito]

je n'arrive en fait pas à "indenter" le code. normalement ca se fait en appuyant sur TAB non?

 

[zeb]

Oups, je t'avais oublié :/

D'abord, sur la forme, quelques conseils.

Dim A$

Je t'invite à être plus explicite, surtout que tu débutes :

Dim reponde As String

Honnêtement, et sans fausse modestie, je ne suis plus débutant. Sache que je continue à être explicite dans mes nommages et typages de variables.
C'est une bonne habitude.

Indente toujours correctement ton code. (Il existe plusieurs écoles. Choisis-en une et tiens-t-y.)
Tu pourras ne plus écrire des choses comme ça :

Next j&

Cela est un vestige du BASIC de 1985 !

Tout comme Goto, que je te vois utiliser.
Vérifie que le code après l'étiquette Erreur: soit bien à exécuter même s'il n'y a pas d'erreur !

---------------

Dis-donc, puisque tu l'utilises, tu connais la fonction Trim() !
Alors utilise-la, lignes 26 à 31.

Ton split en mots est intéressant, mais justement, il existe une fonction qui le fait très bien : Split().
Ah, je te l'accorde, si il y a plusieurs séparateurs qui se suivent, ça peut poser problème.

Dim rep  As String
Dim mots As Variant '// Array

rep = Trim(LCase(rep))
Do While InStr(rep, "  ")
  rep = Replace(rep, "  ", " ")
Loop
mots = Split(rep, " ")

---------------

'// Pas mal
For h& = 1 To WB.Worksheets.Count
    Set S = WB.Worksheets(h& )

Je t'invite à découvrir For Each :

'// Tellement plus simple
For Each feuille In WB.Worksheets

Bon, ensuite tu te lances dans la comparaison de tableaux à plusieurs dimensions... Rholala.
On va repartir de ton laïus :

je voudrais de l'aide si possible. Je n'y connais absolument rien en macro et j'aimerai si possible en faire une qui dans un fichier excel recherche un mot et copie toute les ligne contenant ce mot sur une nouvelle feuille. en gardant bien sur la mise en page et eventuellement les liens hypertexte.
Puis dans un second temps une recherche qui pourra se faire avec 2 mots ou plus (sur des cases differentes)

1°) Avec un mot, pour une feuille

Dim mot     As String
Dim feuille As Worksheet
Dim cellule As Range
Dim ligne   As Range
Dim cible   As Range

'// Ici, il faut fixer mot et feuille
mot = "massekito"
Set feuille = Worksheets(1)
Set cible   = Worksheets(2).Range("A1")

For Each ligne In feuille.UsedRange.Rows
    For Each cellule In ligne.Cells
        If InStr(cellule.Text, mot) > 0 Then
            '// On a trouvé le mot dans une cellule de la ligne
            ligne.Copy Destination:=cible
            Set cible = cible.Offset(1)
            '// Pas la peine de continuer à chercher dans cette ligne
            Exit For
        End If
    Next
Next

Je te laisse digérer tout ça. Puis propose-moi une généralisation à plusieurs mots et à plusieurs feuilles. Si tu n'y arrives pas, je t'aiderai.

 

[massekito]

c'est cool tout ca.
Par contre dans le dernier code j'ai un problème avec la déclaration de la variable feuille.
Lorsque je compile il indique une erreur sur la ligne.

[cpp]feuille = Worksheets(1)[/cpp]

 

[zeb]

Relis mon code !

[atch]

 

[massekito]

Oui dsl...
Donc ca ne marche toujours pas... "Object required"
Les noms par defaut de mes pages sont sheet1 et sheet2 et j'ai même essayé avec worksheet(1) et (2) ca ne marchai pas.
[cpp]Set feuille = Sheet1
Set cible = Sheet2.Range("A1")
[/cpp]

 

[zeb]

Eh, ne soit pas désolé, c'est moi qui avais oublié le Set.
Et en plus, j'avais utilisé de simples quotes (') au lieu de guillemets.

Je viens de tester le code proposé. Il fonctionne :spamafote:​

Attention de bien écrire. worksheet prend un s s'il s'agit de la collection des feuilles.
Pour rappel, Worksheets(1) est un raccourci Worksheets.Item(1). Comprends-tu mieux le pluriel ?
Pour éviter ce genre de problème, utilise l'Option Explicit (lire l'aide à ce sujet).

 

[massekito]

ah oui!! super il marche du tonnerre!! mais du coup ca remplace presque tout mon code... et ca divise le nombre de ligne par 3 et en plus la copie se fait maintenant en conservant la mise en page et les couleurs!! il reste plu qu'un detail maintenant mettre plusieurs mots clé et que la recherche se fasse en "et" et non en "ou". voici le new code j'ai juste changé le mot pour que l'utilisateur puisse choisir lui mm du mot...
[cpp]Option Explicit
Sub Recherche()


Dim mot As String
Dim feuille As Worksheet
Dim cellule As Range
Dim ligne As Range
Dim cible As Range

mot = Application.InputBox("Insert your keyword")
Set feuille = Worksheets(1)
Set cible = Worksheets(2).Range("A1")

For Each ligne In feuille.UsedRange.Rows
For Each cellule In ligne.Cells
If InStr(cellule.Text, mot) > 0 Then
'// On a trouvé le mot dans une cellule de la ligne
ligne.Copy Destination:=cible
Set cible = cible.Offset(1)
'// Pas la peine de continuer à chercher dans cette ligne
Exit For
End If
Next
Next

End Sub
[/cpp]

 

[zeb]

Alors je ne te donne encore de solution, j'attends que tu m'en propose une.
Même si elle ne marche pas du tonnerre, fais-moi des propositions (rien d'indécent, merci).

Une piste pour tes mots multiples, regarde l'opérateur Like

 

[massekito]

opla!!! mais ca ne marche pas bien sûr...en même temps ct evident... en fait je pensais que l'opérateur like allait juste prendre les mots que j'ai écrit et les comparer a tout les mots de chaque ligne....mais non
[cpp]Option Explicit
Option Compare Text '//ne pas tenir compte des majuscules et minuscules
Sub PegaseDebbuger()
Dim mot As String
Dim feuille As Worksheet
Dim cellule As Range
Dim ligne As Range
Dim cible As Range
Worksheets(2).Range("A1:Z1000").ClearContents
'//nettoyage de la feuille de recherche
mot = Application.InputBox( _
"insert your keyword" & vbCrLf & vbCrLf & _
"if more than a word insert a space between each of them")
Set feuille = Worksheets(1)
Set cible = Worksheets(2).Range("A1")

For Each ligne In feuille.UsedRange.Rows
For Each cellule In ligne.Cells
If cellule.Text Like "mot" Then
'// On a trouvé le mot dans une cellule de la ligne
ligne.Copy Destination:=cible
Set cible = cible.Offset(1)
'// Pas la peine de continuer à chercher dans cette ligne
Exit For
End If
Next
Next
Worksheets(2).Cells.Columns.AutoFit
End Sub
[/cpp]

 

[zeb]

Saut,

Je reviens enfin vers toi.
Alors je trouve que tu n'as pas bien étudié Like. Il permet d'utiliser des jokers (*)

Regarde :

If cellule.Text Like "*mot1*mot2*" Then

Bon, évidemment, il faut que tes mots soient dans une cellule et dans l'ordre proposé. Est-ce que cela te convient ?

 

[massekito]

Salut,

Il faut aussi que les mots se suivent(il peut pas y avoir un mot entre les 2)...ca devient un peu contraignant.

 

[zeb]

Bref, il faut juste gérer les espaces entre tes mots, quoi.

Cahier de vacances :

phrase = "   massekito   apprend  le   VB   "


phrase = Replace(phrase, Chr(9), " ")
mots = Split(phrase, " ")
phrase = ""
For Each mot In mots
    If mot <> "" Then
        phrase = phrase & " " & mot
    End If
Next
phrase = Trim(phrase)
    
MsgBox ">" & phrase & "<"

 

[massekito]

Meilleure réponse sélectionnée par massekito.

 

[massekito]

Saut,

Je reviens enfin vers toi.
Alors je trouve que tu n'as pas bien étudié Like. Il permet d'utiliser des jokers (*)

Regarde :

If cellule.Text Like "*mot1*mot2*" Then

Bon, évidemment, il faut que tes mots soient dans une cellule et dans l'ordre proposé. Est-ce que cela te convient ?

Finalement j'ai changé mon fusil d'épaule . Au lieu de se compliquer la tache a faire plusieur mot. On peut faire la recherche plusieurs fois. Sur le résultats de la recherche précedente. voici mon last code et il marche ...
[cpp]Option Explicit
Option Compare Text '//ne pas tenir compte des majuscules et minuscules
Sub PegaseDebbuger()
Dim mot As String
Dim feuille As Worksheet
Dim cellule As Range
Dim ligne As Range
Dim cible As Range
ActiveSheet.Next.Range("A1:Z1000").ClearContents
'//nettoyage de la feuille de recherche
mot = Application.InputBox("Insert your keyword")
Set feuille = ActiveSheet
Set cible = ActiveSheet.Next.Range("A1")

For Each ligne In feuille.UsedRange.Rows
For Each cellule In ligne.Cells
If InStr(cellule.Text, mot) > 0 Then
'// On a trouvé le mot dans une cellule de la ligne
ligne.Copy Destination:=cible
Set cible = cible.Offset(1)
'// Pas la peine de continuer à chercher dans cette ligne
Exit For
End If
Next
Next
ActiveSheet.Next.Cells.Columns.AutoFit
ActiveSheet.Next.Select
End Sub



[/cpp]