Rechercher
Se connecter avec
S'enregistrer | Connectez-vous
Résolu

Macro recherche et copie sur une nouvelle feuille

Dernière réponse : dans Programmation
Partagez

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

Autres pages sur : macro recherche copie nouvelle feuille

Lassé par la pub ? Créez un compte

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

  1. Option Compare Text
    

  2. Sub PegaseDebuggerSearch()
    

  3. Dim WB As Workbook
    

  4. Dim S As Worksheet
    

  5. Dim rep
    

  6. Dim R As Range
    

  7. Dim Titres
    

  8. Dim var
    

  9. Dim dep&
    

  10. Dim g&
    

  11. Dim h&
    

  12. Dim i&
    

  13. Dim j&
    

  14. Dim k&
    

  15. Dim cpt&
    

  16. Dim T()
    

  17. Dim A$
    

  18. Dim B$()
    

  19. On Error GoTo Erreur
    

  20. Titres = Array("PEGASE keyword entered", "File", "range Number", "Reference", "Problem", "Base", "Date", "Keyword #1", "Keyword #2", "Keyword #3", "Keyword #4" )
    

  21. rep = Application.InputBox( _
    

  22.      "insert your keyword" & vbCrLf & vbCrLf & _
    

  23.      "if more than a word insert a space between each of them" )
    

  24. If rep = False Or rep = "" Then Exit Sub
    

  25. A$ = LCase(rep)
    

  26. Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
    

  27.      A$ = Mid(A$, 2)
    

  28. Loop
    

  29. Do Until Right(A$, 1) <> " " And Right(A$, 1) <> Space(1)
    

  30.      A$ = Mid(A$, 1, Len(A$) - 1)
    

  31. Loop
    

  32. If InStr(1, A$, " " ) = 0 Then
    

  33.      ReDim B$(1 To 1)
    

  34.      B$(1) = A$
    

  35. Else
    

  36.      Do Until A$ = ""
    

  37.           If Right(A$, 1) <> " " Then A$ = A$ & " "
    

  38.           i& = i& + 1
    

  39.           ReDim Preserve B$(1 To i& )
    

  40.           B$(i& ) = Mid(A$, 1, InStr(1, A$, " " ) - 1)
    

  41.           A$ = Trim(Mid(A$, Len(B$(i& )) + 2))
    

  42.           Do Until Left(A$, 1) <> " " And Left(A$, 1) <> Space(1)
    

  43.                A$ = Mid(A$, 2)
    

  44.           Loop
    

  45.           B$(i& ) = Trim(B$(i& ))
    

  46.      Loop
    

  47. End If
    

  48. Set WB = ActiveWorkbook
    

  49. For h& = 1 To WB.Worksheets.Count
    

  50.      Set S = WB.Worksheets(h& )
    

  51.      Set R = S.UsedRange
    

  52.      dep& = R.Row
    

  53.      var = R
    

  54.      If R.Columns.Count > 253 Then
    

  55.           MsgBox "file''" & S.Name & _
    

  56.                "'' can't be treated because more than 253 row"
    

  57.      Else
    

  58.           If Not IsEmpty(var) Then
    

  59.                For g& = 1 To UBound(B$)
    

  60.                     For i& = 1 To UBound(var, 1)
    

  61.                          For j& = 1 To UBound(var, 2)
    

  62.                               A$ = LCase(Trim(var(i&, j& )))
    

  63.                               If InStr(1, A$, B$(g& )) > 0 Then
    

  64.                                    cpt& = cpt& + 1
    

  65.                                    ReDim Preserve T(1 To 253, 1 To cpt& )
    

  66.                                    T(1, cpt& ) = B$(g& )
    

  67.                                    T(2, cpt& ) = S.Name
    

  68.                                    T(3, cpt& ) = i& + dep& - 1
    

  69.                                    For k& = 1 To UBound(var, 2)
    

  70.                                         T(k& + 3, cpt& ) = var(i&, k& )
    

  71.                                    Next k&
    

  72.                                    Exit For
    

  73.                               End If
    

  74.                          Next j&
    

  75.                     Next i&
    

  76.                Next g&
    

  77.           End If
    

  78.      End If
    

  79. Next h&
    

  80.      If cpt& = 0 Then
    

  81.           A$ = ""
    

  82.           For i& = 1 To UBound(B$)
    

  83.                A$ = A$ & vbCrLf & B$(i& )
    

  84.           Next i&
    

  85.           MsgBox "no result (verify the spelling)"
    

  86.           Exit Sub
    

  87. Else
    

  88.      Application.ScreenUpdating = False
    

  89.      Set S = Sheets.Add(before:=ActiveSheet)
    

  90.      Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
    

  91.      R = Application.WorksheetFunction.Transpose(T)
    

  92.      Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(Titres) + 1))
    

  93.      R = Titres
    

  94.      R.HorizontalAlignment = xlCenter
    

  95.      R.Font.Bold = True
    

  96.      R.Interior.ColorIndex = 40
    

  97.      S.Cells.Columns.AutoFit
    

  98. End If
    

  99. Erreur:
    

  100. Application.ScreenUpdating = True
    

  101. If Err <> 0 Then MsgBox "Error : " & Err.Number & vbCrLf & Err.Description
    

  102. End Sub


je crois que là ca passe no? :)  :) 

Salut,

Euh... oui et non.... :D 
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'indentation du code.
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. ;) 
Contenus similaires
Posez votre question

Oups, je t'avais oublié :/ 

D'abord, sur la forme, quelques conseils.
  1. Dim A$
Je t'invite à être plus explicite, surtout que tu débutes :
  1. 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 :
  1. 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.

  1. Dim rep  As String
  2. Dim mots As Variant '// Array
  3.  
  4. rep = Trim(LCase(rep))
  5. Do While InStr(rep, "  ")
  6.   rep = Replace(rep, "  ", " ")
  7. Loop
  8. mots = Split(rep, " ")


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

  1. '// Pas mal
  2. For h& = 1 To WB.Worksheets.Count
  3.     Set S = WB.Worksheets(h& )
Je t'invite à découvrir For Each :
  1. '// Tellement plus simple
  2. 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 :
Citation :
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

  1. Dim mot     As String
  2. Dim feuille As Worksheet
  3. Dim cellule As Range
  4. Dim ligne   As Range
  5. Dim cible   As Range
  6.  
  7. '// Ici, il faut fixer mot et feuille
  8. mot = "massekito"
  9. Set feuille = Worksheets(1)
  10. Set cible   = Worksheets(2).Range("A1")
  11.  
  12. For Each ligne In feuille.UsedRange.Rows
  13.     For Each cellule In ligne.Cells
  14.         If InStr(cellule.Text, mot) > 0 Then
  15.             '// On a trouvé le mot dans une cellule de la ligne
  16.             ligne.Copy Destination:=cible
  17.             Set cible = cible.Offset(1)
  18.             '// Pas la peine de continuer à chercher dans cette ligne
  19.             Exit For
  20.         End If
  21.     Next
  22. 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.

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.

  1. feuille = Worksheets(1)

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. :(  :( 
  1. Set feuille = Sheet1
    

  2. Set cible = Sheet2.Range("A1")

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

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 :D  :bounce:  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...
  1. Option Explicit
    

  2. Sub Recherche()
    

  3.  
  4.  
  5. Dim mot    As String
    

  6. Dim feuille As Worksheet
    

  7. Dim cellule As Range
    

  8. Dim ligne  As Range
    

  9. Dim cible  As Range
    

  10.  
  11. mot = Application.InputBox("Insert your keyword")
    

  12. Set feuille = Worksheets(1)
    

  13. Set cible = Worksheets(2).Range("A1")
    

  14.  
  15. For Each ligne In feuille.UsedRange.Rows
    

  16.     For Each cellule In ligne.Cells
    

  17.          If InStr(cellule.Text, mot) > 0 Then
    

  18.              '// On a trouvé le mot dans une cellule de la ligne
    

  19.              ligne.Copy Destination:=cible
    

  20.              Set cible = cible.Offset(1)
    

  21.              '// Pas la peine de continuer à chercher dans cette ligne
    

  22.              Exit For
    

  23.          End If
    

  24.      Next
    

  25.  Next
    

  26.  
  27. End Sub

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

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 :cry:  :cry:  
  1. Option Explicit
    

  2. Option Compare Text '//ne pas tenir compte des majuscules et minuscules
    

  3. Sub PegaseDebbuger()
    

  4. Dim mot    As String
    

  5. Dim feuille As Worksheet
    

  6. Dim cellule As Range
    

  7. Dim ligne  As Range
    

  8. Dim cible  As Range
    

  9. Worksheets(2).Range("A1:Z1000").ClearContents
    

  10. '//nettoyage de la feuille de recherche
    

  11. mot = Application.InputBox( _
    

  12.     "insert your keyword" & vbCrLf & vbCrLf & _
    

  13.     "if more than a word insert a space between each of them")
    

  14. Set feuille = Worksheets(1)
    

  15. Set cible = Worksheets(2).Range("A1")
    

  16.  
  17. For Each ligne In feuille.UsedRange.Rows
    

  18.     For Each cellule In ligne.Cells
    

  19.          If cellule.Text Like "mot" Then
    

  20.              '// On a trouvé le mot dans une cellule de la ligne
    

  21.              ligne.Copy Destination:=cible
    

  22.              Set cible = cible.Offset(1)
    

  23.              '// Pas la peine de continuer à chercher dans cette ligne
    

  24.              Exit For
    

  25.          End If
    

  26.      Next
    

  27.  Next
    

  28. Worksheets(2).Cells.Columns.AutoFit
    

  29. End Sub

Meilleure solution

Saut,

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

Regarde :
  1. 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 ?

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

Cahier de vacances :
  1. phrase = "   massekito   apprend  le   VB   "
    

  2.  
  3.  
  4. phrase = Replace(phrase, Chr(9), " ")
    

  5. mots = Split(phrase, " ")
    

  6. phrase = ""
    

  7. For Each mot In mots
    

  8.     If mot <> "" Then
    

  9.         phrase = phrase & " " & mot
    

  10.     End If
    

  11. Next
    

  12. phrase = Trim(phrase)
    

  13.  
  14. MsgBox ">" & phrase & "<"

zeb a dit :
Saut,

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

Regarde :
  1. 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 :D  . 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 ... :bounce:  :bounce: 
  1. Option Explicit
    

  2. Option Compare Text '//ne pas tenir compte des majuscules et minuscules
    

  3. Sub PegaseDebbuger()
    

  4. Dim mot    As String
    

  5. Dim feuille As Worksheet
    

  6. Dim cellule As Range
    

  7. Dim ligne  As Range
    

  8. Dim cible  As Range
    

  9. ActiveSheet.Next.Range("A1:Z1000").ClearContents
    

  10. '//nettoyage de la feuille de recherche
    

  11. mot = Application.InputBox("Insert your keyword")
    

  12. Set feuille = ActiveSheet
    

  13. Set cible = ActiveSheet.Next.Range("A1")
    

  14.  
  15. For Each ligne In feuille.UsedRange.Rows
    

  16.     For Each cellule In ligne.Cells
    

  17.          If InStr(cellule.Text, mot) > 0 Then
    

  18.              '// On a trouvé le mot dans une cellule de la ligne
    

  19.              ligne.Copy Destination:=cible
    

  20.              Set cible = cible.Offset(1)
    

  21.              '// Pas la peine de continuer à chercher dans cette ligne
    

  22.              Exit For
    

  23.          End If
    

  24.      Next
    

  25.  Next
    

  26. ActiveSheet.Next.Cells.Columns.AutoFit
    

  27. ActiveSheet.Next.Select
    

  28. End Sub
Lassé par la pub ? Créez un compte
 
Posez votre question