Formule recherche VBA [Résolu]

Signaler
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
-
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
-
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

Messages postés
17246
Date d'inscription
dimanche 17 février 2008
Statut
Contributeur
Dernière intervention
14 octobre 2020
4 288
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<>"")) 

Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020
291
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
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1 >
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020

Bonjour Frenchie83,
Je vous joins le fichier : https://www.cjoint.com/c/JJkiHv5qs7r
Par avance, je vous remercie et vous souhaite une excellente journée.
Bien cordialement,
zizou
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020
291 >
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020

Bonjour,
Avec le fichier , je comprends mieux, Vos dates dans "Data 1" et "Data "2 sont au format texte, donc vu par excel comme du texte et non comme des dates.

Une ligne intercalée dans le code s'occupe de faire le nécessaire pour pallier à cela.
Revoici le code
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
        Sheets("Data1").Columns("D:D").NumberFormat = "m/d/yyyy"
        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"
                   f1.Cells(lig, "D") = CDate(f1.Cells(lig, "D"))
                   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


Le fichier
https://mon-partage.fr/f/3zmz9O4f/

Cdlt
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1 >
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020

Bonjour,
Effectivement les données sont extraites en format texte, je vous remercie pour votre aide et votre patience.
Remarque : lorsque je fais une recherche avec le mot (mer) le fichier bug.
Bien à vous,
zizou
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020
291 >
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020

Bonjour,

Voici le code corrigé
Sub Test()
    Dim lig As Long, i As Long, DerLig_f1 As Long, DerLig_Data 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
        Sheets("Data1").Columns("D:D").NumberFormat = "m/d/yyyy"
        Set f2 = Sheets("Data" & i) 'pour chaque feuille "Data"
        DerLig_Data = f2.Range("A" & Rows.Count).End(xlUp).Row
        With f2.Range("A4:AB" & DerLig_Data) '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 x.Row > 3 Then
                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"
                       f1.Cells(lig, "D") = CDate(f1.Cells(lig, "D"))
                       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 And x.Row > 3 'on boucle tant qu'on en trouve et que ce n'est pas le premier déjà trouvé
                End If
            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
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1 >
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020

Re bonjour Frenchie83 ,
Excellent, mille merci à vous...
Bien à vous,
zizou
Messages postés
2165
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
11 octobre 2020
291
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
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1
Bonsoir Mike-31,
j'aurais aimer en VBA c'est possible?
Merci par avance,
zizou
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1
bonjour quelqu'un pourrait m'aider? SVP...
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1
Super, je te remercie beaucoup, c'est possible d'inclure la période (voir C2 & D2)?
Cordialement,
zizou
Messages postés
71
Date d'inscription
dimanche 1 février 2009
Statut
Membre
Dernière intervention
11 octobre 2020
1
C'est exactement ce qu'il me fallait ÉNORME MERCI.
Cordialement,
zizou