mot a rechercher

judoka0209

XLDnaute Occasionnel
bonjour a tous et merci pour le temps passé

j'ai crée une macro qui marche, qui cherche un mot "CB" mais lorsque je la lance il me trouve rien si il est dans du texte et pas seul dans une colonne
j'espere mettre bien exprime sur mon attente

je vous joint le fichier
Sub Macro1()
'twb fait référence au classeur en cours
Set twb = ThisWorkbook
Dim resultat As String
' on demande le texte"
resultat = InputBox("Entrer le texte :", "mot") 'La variable reçoit la valeur entrée dans l'InputBox

If resultat <> "" Then 'Si la valeur est différente de "" on affiche le résultat
MsgBox "le texte est " & resultat
End If
' on va parcourir un à un toutes les feuilles du classeur en cours, ws identifie chacune de ces feuilles
i = 0
For Each ws In twb.Worksheets
' on recherche le texte dans la feuille ws
Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)

If Not trouve Is Nothing Then
pAddresse = trouve.Address
If i = 0 Then Set nwb = Workbooks.Add

Do
i = i + 1
ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("A" & i)
Set trouve = ws.Cells.FindNext(trouve)
Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
End If

' on passe au classeur suivant
Next
If i = 0 Then
MsgBox "lio non trouvé"
End If
End Sub
 

Pièces jointes

  • synthese.xlsm
    151.9 KB · Affichages: 66

Bebere

XLDnaute Barbatruc
Dodo,Judoka
ajout de thisworbook,le classeur créé devient actif
ne trouve plus les feuilles du classeur qui contient l'userform
dans ce cas il n'y a pas besoin de boucle pour la listbox
il n'y a qu'une sélection
mis la boucle feuilles en 1er
Code:
Private Sub ListBox1_Click()

    Application.ScreenUpdating = False

    x = 0
        For k = 1 To Sheets.Count
            If ThisWorkbook.Sheets(k).Name <> "Liste" Then
            Set Ws = ThisWorkbook.Sheets(k)
            Else
            Exit For
            End If
    For i = 0 To ListBox1.ListCount
                If ListBox1.Selected(i) = True Then
                    critere = ListBox1.List(i)
                    Set cel = Ws.Cells.Find(critere, LookIn:=xlValues, LookAt:=xlPart)
                    If Not cel Is Nothing Then
                        pAddress = cel.Address
                        If x = 0 Then Set Nwb = Workbooks.Add
                        Do
                            x = x + 1
                            Ws.Cells(cel.Row).Copy _
                                    Nwb.Sheets(1).Range("a" & x)
                            Set cel = Ws.Cells.FindNext(cel)
                        Loop While Not cel Is Nothing And cel.Address <> pAddress
'                        Else
'                        MsgBox "erreur"
                    End If
                End If
           
    Next i
        Next k
    Nwb.Sheets(1).Range("A:I").Columns.AutoFit
End Sub
 

Bebere

XLDnaute Barbatruc
bonjour Dodo,Judoka
ce code donne un résultat
ajouté du code pour sauver le classeur avec un nom
le dossier sera le dossier défini dans excel,içi C:\Documents\
Code:
Private Sub ListBox1_Click()
    Dim nom As String
    Application.ScreenUpdating = False

    x = 0
    For k = 1 To Sheets.Count
        If ThisWorkbook.Sheets(k).Name <> "Liste" Then
            Set Ws = ThisWorkbook.Sheets(k)
            critere = ListBox1    '.List(i)
            Set cel = Ws.Cells.Find(critere, LookIn:=xlValues, LookAt:=xlPart)
            If Not cel Is Nothing Then
                pAddress = cel.Address
                If x = 0 Then Set Nwb = Workbooks.Add
                Do
                    x = x + 1
                    Ws.Range("A" & cel.Row & ":D" & cel.Row).Copy _
                            Nwb.Sheets(1).Range("a" & x)
                    Set cel = Ws.Cells.FindNext(cel)
                Loop While Not cel Is Nothing And cel.Address <> pAddress
            End If
        Else
            Exit For
        End If
        nom = nom & Ws.Name & "-"
    Next k
   
    nom = Left(nom, Len(nom) - 1) & critere
    Nwb.Sheets(1).Columns.AutoFit
    Nwb.SaveAs Filename:=nom & ".xls"    ' tu peux ajouter un dossier
    Nwb.Close True
End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re René

Cette fois c'est OK avec ceci. Mais, comme certaines cellules(et je ne sais pas comment il a fait ça, quel horreur :eek:) il y a des retours à la ligne pas possibles, c'est un peu n'importe quoi, vu qu'on peux aller jusqu'à 1000000 de lignes.

VB:
Private Sub ListBox1_Click()
    Call test
End Sub

Sub test()
    Application.ScreenUpdating = False

    x = 0
    col = 1
           For i = 0 To ListBox1.ListCount - 1
           If ListBox1.Selected(i) = True Then
            critere = ListBox1.List(ListBox1.ListIndex, 0)
            Exit For
            End If
            Next i
            For Each Ws In ThisWorkbook.Sheets
                Set cel = Ws.Cells.Find(critere, , xlValues, xlPart, xlByRows, xlNext)
                If Not cel Is Nothing Then
                    pAddress = cel.Address
                    If x = 0 Then Set Nwb = Workbooks.Add
                    Do
                        x = x + 1
                        With Nwb.Sheets(1)
                        Set plage = .Range("a" & x)
                        End With
                        Ws.Range("A" & cel.Row & ":D" & cel.Row).Copy plage
                                      Nwb.Sheets(1).Range("A:I").Columns.AutoFit
                        Set cel = Ws.Cells.FindNext(cel)
                    Loop While Not cel Is Nothing And cel.Address <> pAddress
                End If
            Next Ws
   
End Sub


Ici mot recherché = VIR

NpQ.gif
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 794
Membres
101 817
dernier inscrit
carvajal