Macro recherche

Bonsoir le forum,

Pourriez-vous m'aider à mettre en place une macro qui va aller chercher les informations de la feuille DATA pour les implémenter dans la feuille suivi en fonction des trois critères de cette même feuille (B1 à B3).

En vous remerciant.

Cdlt

Max

Bonjour, un exemple sans macro.

Méfiance, dans la feuille data il y a un espace après "VO" que l'on ne retrouve pas en Q2 ce qui rend la recherche infructueuse en tout point.

bonjour

bonjour force rouge

il me semble avoir detecté un leger bug avec "aucune correspondance " en valeur d'erreur ...... mais rien de letal

14max-6546.xlsx (65.96 Ko)

cordialement

Salutation tulip4, je pensais l'avoir viré se else:msgbox "aucune correspondance" ...C'est sur quel fil déjà ?

Bonjour,

Merci à vous, c'est le résultat recherché.

Sachant que je vais compiler des données dans la base DATA, j'ai peur qu'il y ait des temps de calcul assez long avec les formules matricielles.

Une solution macro est-elle possible?

En vous remerciant

Max

re force rouge

dans ta pj (que j'ai reutilisée)

mais bon ....c'est rien ;;; fait nous un bon truc en vba comme d'hab

cordialement

Merci de ton encouragement tulipe_4, bon truc bon truc...J'apprends tout en aidant donc je fais ce que je peux avec ce qu'il me reste en reflexion. Pour une macro, j'ai pu faire ceci:

Sub macro()
    Dim dl&, i%, tablo()
    dl = Feuil2.Range("a" & Rows.Count).End(xlUp).Row
    tablo = Feuil2.Range("a1:ae" & dl)
    For i = 2 To UBound(tablo)
        If tablo(i, 31) = Feuil3.[b1] And tablo(i, 12) = Feuil3.[b2] And tablo(i, 26) = Feuil3.[b3] Then
            Feuil3.[A65536].End(xlUp)(2) = tablo(i, 13)
            Feuil3.[b65536].End(xlUp)(2) = tablo(i, 27)
            Feuil3.[c65536].End(xlUp)(2) = tablo(i, 28)
        End If
    Next
End Sub

A noter que pour PMG dans le commentaire c'est écrit qu'il faut chercher dans colonne z alors que pmg est aussi en colonne x...

Merci pour cette macro qui marche très bien.

C'est vrai qu'il y a plusieurs colonne PMG, c'est la colonne X qui me sert.

pour info, j'ai un fichier similaire avec une macro adaptée,mais je n'arrive pas à l'adapter à ce fichier.

Autant la fin c'est faisable, mais autant pour le début je galère.

La voici:

Option Explicit
Dim tblo(), i As Long, xlgn As Long, xlgndata As Long, xresultat As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("$B$2")) Is Nothing Then
        xlgn = Range("A65536").End(xlUp).Row + 1
        Range("A4:J" & xlgn).ClearContents
        ' Transfert données dans le tableau
       xlgndata = Sheets("DATA").Range("A65536").End(xlUp).Row
        ReDim tblo(xlgn, 48)
        tblo() = Sheets("DATA").Range("A2:AV" & xlgndata).Value
        ' affectation des variables pour la recherche
       xresultat = False
        xlgn = Sheets("Needed Kit's Component").Range("A65536").End(xlUp).Row
            For i = LBound(tblo, 1) To UBound(tblo, 1)
                If tblo(i, 23) = Cells(2, 2).Value And tblo(i, 48) = Cells(1, 2).Value Then
                    xresultat = True: xlgn = xlgn + 1
                        With Sheets("Needed Kit's Component")
                            .Range("A" & xlgn) = tblo(i, 3)
                            .Range("B" & xlgn) = tblo(i, 4)
                            .Range("C" & xlgn) = tblo(i, 5)
                            .Range("D" & xlgn) = tblo(i, 6)
                            .Range("E" & xlgn) = tblo(i, 10)
                            .Range("F" & xlgn) = tblo(i, 1)
                            .Range("G" & xlgn) = tblo(i, 19)
                            .Range("H" & xlgn) = tblo(i, 20)
                            .Range("I" & xlgn) = tblo(i, 21)
                            .Range("J" & xlgn) = tblo(i, 22)
                        End With
                End If
            Next i
        If xresultat = False Then MsgBox "Aucune donnée pour cette sélection de paramètres."
        Erase tblo
    End If
End Sub

 

De plus il a un userform, qui donne un message d'alerte si le code PMG n'est pas conue.

Cordialement,

max

Bonjour, dans votre cas un filtre élaboré est peut-être plus préférable pour les raisons suivantes :

Peu de ligne de code donc pas besoin de support N3 pour la maintenance du code.

Donnée exploitable sans risque d’altérer la base de donnée primaire car c'est une extraction

Le vendredi à 17h29 quant vous êtes pret à partir en week-end et que votre chef vous demande une extraction, vous avez peu de chance d'avoir un message du genre "erreur '261886481684' l'application a mal fonctionné" où dans se genre de cas, vous avez deux attention braquées sur vous. La premiere de votre chef qui se réjouit de voir que sa marche pas et que vous allez rester avec lui le temps de résoudre le problème et l'éditeur vba qui lui, c'est figé sur la ligne d'erreur et attends une solution pour que le programme fonctionne. Résultat au lieu de partir une minute plus tard en week-end vous partirez....Une heure après ! Si toute fois vous avez trouvé une âme charitable...

Pour le fichier, il suffit d'entrer des critères dans la feuille suivi dans les cases bleues...

Bonsoir à tous

Ou tout simplement :

Sub Copy()
Dim a, b(), i As Long, n As Long
    a = Sheets("Data").Range("a1").CurrentRegion.Value
    x = Sheets("Suivi").Range("B1:B3")
    ReDim b(1 To UBound(a, 1), 1 To 3)
    For i = 2 To UBound(a, 1)
        If (a(i, 12) = x(2, 1)) * (a(i, 24) = x(3, 1)) * (a(i, 31) = x(1, 1)) Then
            n = n + 1
            b(n, 1) = a(i, 13)
            b(n, 2) = a(i, 27)
            b(n, 3) = a(i, 28)
        End If
    Next
    If n > 0 Then
        Sheets("Suivi").Range("A5").Resize(n, UBound(b, 2)) = b
    Else
        MsgBox "Aucune donnée"
    End If
End Sub

klin89

Klin89 a écrit :

Bonsoir à tous Ou tout simplement

Oui tout simplement ! Quand je vois ta macro je me dis que j'ai encore beaucoup à apprendre !

Rechercher des sujets similaires à "macro recherche"