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