Formule recherche VBA

Résolu
zizou026 Messages postés 102 Statut Membre -  
zizou026 Messages postés 102 Statut Membre -
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 Messages postés 18405 Date d'inscription   Statut Contributeur Dernière intervention   5 147
     
    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
  2. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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 Messages postés 102 Statut Membre 1
       
      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 Messages postés 2254 Statut Membre 339 > zizou026 Messages postés 102 Statut Membre
       
      Bonjour,

      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 Messages postés 102 Statut Membre 1 > Frenchie83 Messages postés 2254 Statut Membre
       
      Bonjour Frenchie83,
      Mes sincère remerciement pour votre explication, les résultats ne s'affichent pas...
      Cordialement,
      zizou
      0
    4. Frenchie83 Messages postés 2254 Statut Membre 339 > zizou026 Messages postés 102 Statut Membre
       
      Bonjour,

      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 Messages postés 102 Statut Membre 1 > Frenchie83 Messages postés 2254 Statut Membre
       
      Bonjour Frenchie83,
      Je ne sais pas comment vous remercier, je prépare le fichier...
      Cdlt,
      zizou
      0
  3. Frenchie83 Messages postés 2254 Statut Membre 339
     
    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
  4. zizou026 Messages postés 102 Statut Membre 1
     
    Bonsoir Mike-31,
    j'aurais aimer en VBA c'est possible?
    Merci par avance,
    zizou
    0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. zizou026 Messages postés 102 Statut Membre 1
     
    bonjour quelqu'un pourrait m'aider? SVP...
    0
  7. zizou026 Messages postés 102 Statut Membre 1
     
    Super, je te remercie beaucoup, c'est possible d'inclure la période (voir C2 & D2)?
    Cordialement,
    zizou
    0
  8. zizou026 Messages postés 102 Statut Membre 1
     
    C'est exactement ce qu'il me fallait ÉNORME MERCI.
    Cordialement,
    zizou
    0

Discussions similaires

Réglage chaine de la TNT FR3 TF1 A2 TMC
Yamina -
Redbart -

1 réponse
exo pix
Xtyller -
Raymond PENTIER -

2 réponses