Formule recherche VBA

Résolu
zizou026 -  
Bonjour,

J'ai trouvé un fichier avec un début de code en VBA, auriez-vous l'amabilité? De m'aider à mettre en place pour une :

Recherche par texte ou numérique et par période (voir fichier).

https://www.cjoint.com/c/JHfrUmz0mEr

Par avance, je vous remercie.

Cordialement,

Zizou

7 réponses

  1.  Mike-31
    Bonjour,

    tu peux faire avec une formule 

    =SOMMEPROD((Data1!H2:H20=Résultat!B2)*(Data1!G2:G20>=Résultat!C2)*(Data1!G2:G20<=Résultat!D2)*(Data1!H2:H20<>""))+SOMMEPROD((Data2!H2:H20=Résultat!B2)*(Data2!G2:G20>=Résultat!C2)*(Data2!G2:G20<=Résultat!D2)*(Data2!H2:H20<>""))

    1
    1. Frenchie83
      Bonjour,

      Essayez ceci
      https://mon-partage.fr/f/pH0RtFBu/

      le code 
      Option Explicit

Sub Test()
    Dim lig As Long, i As Long
    Dim x As Range
    Dim f1 As Worksheet, f2 As Worksheet
    Dim PosDeb As String
    Application.ScreenUpdating = False
    Set f1 = Sheets("Résultat")
    
    f1.Range("A4:H" & Rows.Count).ClearContents
    lig = 4
    For i = 1 To 2
        Set f2 = Sheets("Data" & i)
        With f2.Columns("A:H")
            Set x = .Find(f1.Range("B2"), lookat:=xlPart)
            If Not x Is Nothing Then
                PosDeb = x.Address
                Do
                   f2.Range(f2.Cells(x.Row, "A"), f2.Cells(x.Row, "H")).Copy f1.Cells(lig, "A")
                   lig = lig + 1
                   Set x = .FindNext(x)
                Loop While Not x Is Nothing And x.Address <> PosDeb
            End If
        End With
    Next i
    
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub


      Cdlt
      1
      1. zizou026 Auteur
        Bonjour Frenchie83
        Question : dans mon tableau réel les données s'étendent jusqu'à la colonne AB et les dates sont dans la colonne D.
        Que dois je changer pour les résultats s'affichent?
        Par avance, je vous remercie.
        Zizou
        0
      2. Frenchie83
        @zizou026Bonjour,

        Voici, mais je n'ai pas testé

        Option Explicit 

        Sub Test()
    Dim lig As Long, i As Long, DerLig_f1 As Long
    Dim x As Range
    Dim f1 As Worksheet, f2 As Worksheet
    Dim PosDeb As String
    Dim DateDeb As String, DateFin As String
    Application.ScreenUpdating = False
    Set f1 = Sheets("Résultat")
    
    f1.Range("A4:AB" & Rows.Count).ClearContents
    lig = 4
    For i = 1 To 2
        Set f2 = Sheets("Data" & i) 'pour chaque feuille "Data"
        With f2.Columns("A:AB") 'des colonnes A à AB de la feuille "Data" traitée
            Set x = .Find(f1.Range("B2"), lookat:=xlPart) 'recherche du Critère en B2 de la feuille "Résultat"
            If Not x Is Nothing Then 'Si la valeur est trouvée
                PosDeb = x.Address 'on relève la position
                Do ' puis on fait
                   f2.Range(f2.Cells(x.Row, "A"), f2.Cells(x.Row, "AB")).Copy f1.Cells(lig, "A") 'copie dans "Résultat" des valeurs trouvées dans "Data"
                   lig = lig + 1 'on incrémente la ligne de "résultat"
                   Set x = .FindNext(x) 'recherche du prochain emplacement du critère dans "Data"
                Loop While Not x Is Nothing And x.Address <> PosDeb 'on boucle tant qu'on en trouve et que ce n'est pas le premier déjà trouvé
            End If
        End With
    Next i 'on passe à la feuille "Data" suivante
    
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne de "Résultat"
    DateDeb = ">=" & f1.Range("C2") * 1 'Valeur seuil de la date de début
    DateFin = "<=" & f1.Range("D2") * 1 'Valeur seuil de la date de fin
    f1.Range(Cells(3, "A"), Cells(DerLig_f1, "AB")).AutoFilter Field:=4, Criteria1:=DateDeb, Operator:=xlAnd, Criteria2:=DateFin 'Filtrage
    
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub


        Cdlt
        0
      3. zizou026 Auteur
        @Frenchie83Bonjour Frenchie83,
        Mes sincère remerciement pour votre explication, les résultats ne s'affichent pas...
        Cordialement,
        zizou
        0
      4. Frenchie83
        @zizou026Bonjour,

        Afin que je puisse voir la structure réelle de ce fichier, pourriez-vous déposer le vrai fichier vidé de ses données confidentielles?

        Cdlt
        0
      5. zizou026 Auteur
        @Frenchie83Bonjour Frenchie83,
        Je ne sais pas comment vous remercier, je prépare le fichier...
        Cdlt,
        zizou
        0
    2. Frenchie83
      Voilà 
      Option Explicit

Sub Test()
    Dim lig As Long, i As Long, DerLig_f1 As Long
    Dim x As Range
    Dim f1 As Worksheet, f2 As Worksheet
    Dim PosDeb As String
    Dim DateDeb As String, DateFin As String
    Application.ScreenUpdating = False
    Set f1 = Sheets("Résultat")
    
    f1.Range("A4:H" & Rows.Count).ClearContents
    lig = 4
    For i = 1 To 2
        Set f2 = Sheets("Data" & i)
        With f2.Columns("A:H")
            Set x = .Find(f1.Range("B2"), lookat:=xlPart)
            If Not x Is Nothing Then
                PosDeb = x.Address
                Do
                   f2.Range(f2.Cells(x.Row, "A"), f2.Cells(x.Row, "H")).Copy f1.Cells(lig, "A")
                   lig = lig + 1
                   Set x = .FindNext(x)
                Loop While Not x Is Nothing And x.Address <> PosDeb
            End If
        End With
    Next i
    
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DateDeb = ">=" & f1.Range("C2") * 1
    DateFin = "<=" & f1.Range("D2") * 1
    f1.Range(Cells(3, "A"), Cells(DerLig_f1, "H")).AutoFilter Field:=7, Criteria1:=DateDeb, Operator:=xlAnd, Criteria2:=DateFin
    
    Set x = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub


      Cdlt
      1
      1. zizou026 Auteur
        Bonsoir Mike-31,
        j'aurais aimer en VBA c'est possible?
        Merci par avance,
        zizou
        0
        2. zizou026 Auteur
          bonjour quelqu'un pourrait m'aider? SVP...
          0
          1. zizou026 Auteur
            Super, je te remercie beaucoup, c'est possible d'inclure la période (voir C2 & D2)?
            Cordialement,
            zizou
            0
            1. zizou026 Auteur
              C'est exactement ce qu'il me fallait ÉNORME MERCI.
              Cordialement,
              zizou
              0

              Discussions similaires

              exo pix
              Xtyller

              2 réponses
              Réglage chaine de la TNT FR3 TF1 A2 TMC
              Yamina

              1 réponse