Copier lignes en fonction des numéros trouvés/ Mise en forme

Bonjour,

J'ai besoin de votre aide. Je suis débutante en VBA.

J'ai trouvé un code sur le forum qui me permet d'afficher les numéros de lignes correspondants à ma recherche.

J'aimerai désormais pouvoir copier les lignes concernées dans la feuille, "Feuil1".

Je vous joints mon fichier, et voici le code:

Sub Test()

Dim Tablo() As Long

Dim I As Integer

Dim Lignes As String

Dim MonMot As String

MonMot = "OK" '<-- adapter le mot recherché...

Tablo = Rechercher(MonMot)

If Tablo(1) = -1 Then

MsgBox "Le mot '" & MonMot & "' est introuvable !"

Exit Sub

End If

'Lignes = "Les lignes où se trouve le mot recherché sont : "

For I = 1 To UBound(Tablo)

Lignes = Lignes & vbCrLf & Tablo(I)

Next I

MsgBox Lignes

End Sub

Function Rechercher(Mot As String) As Long()

Dim Plage As Range

Dim Cel As Range

Dim Tbl() As Long

Dim Adr As String

Dim I As Integer

With ActiveSheet

Set Plage = .Range(.Cells(2, 10), .Cells(.Rows.Count, 10).End(xlUp))

End With

Set Cel = Plage.Find(Mot, , xlValues, xlWhole)

If Not Cel Is Nothing Then

Adr = Cel.Address

Do

I = I + 1

ReDim Preserve Tbl(1 To I)

Tbl(I) = Cel.Row

Set Cel = Plage.FindNext(Cel)

Loop While Adr <> Cel.Address

Else

ReDim Tbl(1 To 1)

Tbl(1) = -1

End If

Rechercher = Tbl()

End Function

Merci d 'avance pour votre aide.

13basededonnees4.xlsm (31.16 Ko)

Bonjour Syd, bonjour le forum,

Peut-être comme ça :

Sub Test()
Dim O1 As Worksheet 'déclare la variable O1 (onglet 1)
Dim O2 As Worksheet 'déclare la variable O2 (onglet 2)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim MR As Variant 'déclare la variable MR (Mot Recherché)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set O1 = Worksheets("Filtre Famille") 'définit l'onglet O1
Set O2 = Worksheets("Feuil1") 'définit l'onglet O2
TV = O1.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
O2.Cells.ClearContents 'efface d'éventuelles anciennes valeur dans l'onglet O2
O2.Range("A1").Resize(1, NC).Value = Application.Index(TV, 1) 'recopie la ligne des en-têtes du tableau dans l'onglet O2
MR = Application.InputBox("Tapez le mot à rechercher.", "RECHERCHE", Type:=2) 'définit le mot recherché MR
If MR = "" Or MR = False Then Exit Sub 'si Mr non renseigné ou bouton [Annuler], sort de la procédure
K = 1 'initialise la variable K
For I = 2 To NL 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    For J = 1 To NC 'boucle 1 : sur toutes les colonnes J du tableau des valeurs TV
        If UCase(TV(I, J)) = UCase(MR) Then 'condition : si la données ligne I colonne J de TV (convertie en majuscule) est égale à MR (convertie en majuscule)
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionne le tableau ds lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'boucle 3 sur toutes les lignes L du tableau des lignes TL
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (= Transposition)
            Next L 'prochaine ligne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
            Exit For 'sort de la boucle 2
        End If 'fin de la condition
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
'si K est supérieure à 1, renvoie dans A2 redimensionnée de l'onglet O2 le tableu TL transposé
If K > 1 Then O2.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
O2.Activate 'active l'onglet O2
End Sub

Re

ça fonctionne !!!

Merci Beaucoup

Rebonjour ThauThème

Merci pour ton code qui fonctionne très bien. Mais j'aimerais si possible faire une modification pour gagner du temps.

Si je ne veux pas à chaque fois saisir la valeur recherchée mais qu'il recherche automatiquement "OK". Comment faire ? J'aimerais enlever l'application inputbox en fait.

Merci de ton aide

Bonjour Syd, bonjour le forum,

Essaie comme ça :

Sub Test()
Dim O1 As Worksheet 'déclare la variable O1 (onglet 1)
Dim O2 As Worksheet 'déclare la variable O2 (onglet 2)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Long 'déclare la variable NL (Nombre de Lignes)
Dim NC As Integer 'déclare la variable NC (Nombre de Colonnes)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set O1 = Worksheets("Filtre Famille") 'définit l'onglet O1
Set O2 = Worksheets("Feuil1") 'définit l'onglet O2
TV = O1.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
O2.Cells.ClearContents 'efface d'éventuelles anciennes valeur dans l'onglet O2
O2.Range("A1").Resize(1, NC).Value = Application.Index(TV, 1) 'recopie la ligne des en-têtes du tableau dans l'onglet O2
K = 1 'initialise la variable K
For I = 2 To NL 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    For J = 1 To NC 'boucle 1 : sur toutes les colonnes J du tableau des valeurs TV
        If UCase(TV(I, J)) = "OK" Then 'condition : si la données ligne I colonne J de TV (convertie en majuscule) est égale à "OK"
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionne le tableau ds lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'boucle 3 sur toutes les lignes L du tableau des lignes TL
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (= Transposition)
            Next L 'prochaine ligne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
            Exit For 'sort de la boucle 2
        End If 'fin de la condition
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
'si K est supérieure à 1, renvoie dans A2 redimensionnée de l'onglet O2 le tableu TL transposé
If K > 1 Then O2.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
O2.Activate 'active l'onglet O2
End Sub

Merci Beaucoup !!!


Re Thauthème

Je me permets d'abuser de ta gentillesse, mais à tout hasard est-ce que tu saurais répondre à la question que j'ai posté aujourd'hui à 12:33 sur le forum ?

Personne ne réponds et je suis bloquée pour avancer...

Merci pour tout

Re Bonjour Thauthème

Sauriez-vous modifier votre code pour conserver le format texte des cellules ?

Je ne sais pas comment ni ou insérer un PasteSpecial Paste=:XlPasteFormats dans toutes les boucles de votre code ...

Merci de votre aide

Bonjour Tautheme

Comme vous pouvez le voir dans dans le fichier joint, votre code marche très bien

Cependant j'aimerais pouvoir conserver la mise en forme du texte lors de la copie, mais je ne sais pas ou insérer un PasteSpecial Paste=:XlPasteFormats dans toutes les boucles de votre code ...

Et je me demandais aussi s'il était possible que les cellules qui étaient groupées reste groupées lors du collage ?

Merci pour votre aide

PS : Je me suis permise de continuer le post car je pense que vous êtes le plus à même (si c'est possible) de modifier votre code.

Bonjour Syd, le forum,

La méthode que j'ai utilisée ne prend pas en compte les mises en forme mais uniquement les données. Il faudrait changer de méthode mais je n'en ai ni l'envie ni le temps. Désolé et bonne chance...

Re,

Merci pour votre réponse bien que négative.

Si quelqu'un sur le forum a le temps et l'envie , je suis preneuse ...

Merci

Bonjour,

J'ai trouvé la solution ci-dessous.

Dim I As Long   'ligne feuil1
    Dim J As Long   'ligne feuil2
  Dim n As Long   'nombre de ligne tableau feuil1

    J = 1   '1ère ligne où on va coller
    With Sheets("Filtre Famille")
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        For I = 1 To n          'boucle sur lignes à copier si OK
            If .Range("J" & I).Value = "OK" Then
                .Rows(I).Copy
                Sheets("Choix").Range("A" & J).PasteSpecial
                J = J + 1   'prochaine ligne où on va coller
            End If
       Next I
    End With

et je remet le tableau à zéro de cette manière à chaque fois que je ferme mon userform

Sheets("Choix").Range("A2:A800").ClearContents
Sheets("Choix").Range("B2:B800").ClearContents
Sheets("Choix").Range("C2:C800").ClearContents
Sheets("Choix").Range("D2:D800").ClearContents
Sheets("Choix").Range("E2:E800").ClearContents
Sheets("Choix").Range("F2:F800").ClearContents
Sheets("Choix").Range("H2:H800").ClearContents
Sheets("Choix").Range("I2:I800").ClearContents
Sheets("Choix").Range("J2:J800").ClearContents

Voila

A+

Rechercher des sujets similaires à "copier lignes fonction numeros trouves mise forme"