Rechercher et copier coller des données VBA

Bonjour à tous,

Je souhaiterais pouvoir rechercher des données dans une BDD que j'ai. Un fois l’élément trouvé, je souhaiterais copier et coller certaines colonnes de cette même ligne. Je sais faire ceci sans VBA, mais cela me fait perdre trop de temps : Rechercher dans le classeur 1, Colonne A le mot clé. Sélectionner uniquement les cellules visibles (je masque les colonnes qui ne m'intéressent pas, copier et coller dans un autre onglet. Je souhaiterais automatiser ce processus avec VBA.

L'idéal serait :

- avoir 2 onglets : 1 BDD, 1 Résultats

- Avoir un input box qui me demande ce que je recherche (dans colonne A de l'onglet BDD)

- que l'information voulu (certaines colonnes d'une ligne précise) se copie colle sur l'onglet résultats.

- pouvoir faire une deuxième, troisième, etc rechercher et que les lignes copié se collent à la suite de la feuille résultat

Je mets en PJ un classeur Excel schématique de ce que je souhaiterais faire.

Merci d'avance pour toute l'aide que vous pourrez m'apporter.

Si je n'ai pas été assez précise, n'hésitez pas à me le signaler. :)

Bonjour et bienvenue sur le forum

Un essai à tester. Te convient-il ?

Option Explicit

Dim fR As Worksheet, tablo, tabloP, tabloR(), v
Dim i&, j&, k&, n&, ln&, derln&

Private Sub CommandButton1_Click()  'Bouton Fermer
    Unload Me
End Sub

Private Sub CommandButton2_Click()

    For n = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(n) Then
            ln = ListBox1.Column(1, n)
            derln = fR.Range("B" & Rows.Count).End(xlUp)(2).Row
            Range("A" & ln & ":B" & ln + 4).Copy fR.Range("A" & derln)
            Range("D" & ln & ":D" & ln + 4).Copy fR.Range("C" & derln)
        End If
    Next n
    fR.Activate
    Unload Me
End Sub

Private Sub UserForm_Initialize()

    Set fR = Sheets("Résultats")
    tablo = Range("A1").CurrentRegion
    ReDim tabloR(1 To UBound(tablo, 1), 1 To 4)
    ReDim tabloP(1 To (UBound(tablo, 1) - 1) / 5, 1 To 2)
    ListBox1.ColumnCount = 2
    ListBox1.ColumnWidths = "130;10"

    'chargement d taboP 'P comme provisoire
    For i = 2 To UBound(tablo, 1) Step 5
        tabloP((i + 3) / 5, 1) = tablo(i, 1)
        tabloP((i + 3) / 5, 2) = i     'on met le n° de la ligne dans tabloP
    Next i

    'classement des noms dans la listBox1
    For i = 1 To UBound(tabloP, 1)
        For j = 1 To UBound(tabloP, 2)
            If tabloP(i, 1) < tabloP(j, 1) Then    ' 1 pour tri selon la 1ère colonne
                For k = 1 To UBound(tabloP, 2)
                    v = tabloP(i, k)
                    tabloP(i, k) = tabloP(j, k)
                    tabloP(j, k) = v
                Next k
            End If
        Next j
    Next i
    ListBox1.List = tabloP

End Sub

Bye !

gmb, merci pour ta réponse effectivement c'est l'idée !

Comment pourrait-on faire pour faire une recherche de prénom et non les sélectionner dans la liste. En réalité j'ai plus de 6000 prénoms (en réalité des références), tous différents. Je souhaiterais maintenir la base que tu as faite qui correspond au résultat que je souhaite mais ajouter une recherche parmi les prénoms puisque les sélectionner sur une liste déroulante serait trop long avec 6000 prénoms).

Merci à nouveau pour ton aide !

Bonjour

Nouvelle version.

Option Explicit

Dim fb As Worksheet, cell As Range
Dim ln&, derln&

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address <> "$B$4" Then Exit Sub
    Application.EnableEvents = False
    Set fb = Sheets("BDD")
    Set cell = fb.Range("A:A").Find(Target.Value, lookat:=xlWhole)
    If Not cell Is Nothing Then
        ln = cell.Row

        derln = Range("B" & Rows.Count).End(xlUp)(2).Row
        fb.Range("A" & ln & ":B" & ln + 4).Copy Range("A" & derln)
        fb.Range("D" & ln & ":D" & ln + 4).Copy Range("C" & derln)
    Else
        MsgBox Target.Value & " n'existe pas dans la BDD.", 16
    End If

   Application.EnableEvents = True
End Sub

Sub RAZ()

    Set plage = Range("A6").CurrentRegion.Offset(1, 0)
    plage.UnMerge
    plage.Clear
End Sub

Bye !

Salut,

Merci ça me parait pas mal du tout. Saurais-tu pourquoi je ne peux pas ajouter deux éléments à la suite quand j'adapte cela à mon fichier ?

Voici l'erreur indiquée : fb.Range("A" & ln & ":B" & ln + 19).Copy Range("A" & derln)

Merci à toi !

Bonjour

Désolé mais il faudrait que je dispose de ton fichier tel qu'il est quand ça bugue.

Bye !