Formule recherche VBA

Résolu/Fermé

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 - 5 août 2020 à 19:52
zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 - 11 oct. 2020 à 12:28

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

A voir également:

Formule recherche VBA
Formule excel - Guide
Formule si et - Guide
Recherche musique - Guide
Formule moyenne excel - Guide
Formule excel pour additionner plusieurs cellules - Guide

7 réponses

Réponse 1 / 7

Mike-31 Messages postés 18310 Date d'inscription dimanche 17 février 2008 Statut Contributeur Dernière intervention 29 mars 2024 5 073
5 août 2020 à 20:49

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<>""))

Réponse 2 / 7

Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 337
27 sept. 2020 à 13:24

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

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1
5 oct. 2020 à 17:31

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

Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 337 > zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021
5 oct. 2020 à 19:31

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

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1 > Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023
8 oct. 2020 à 07:38

Bonjour Frenchie83,
Mes sincère remerciement pour votre explication, les résultats ne s'affichent pas...
Cordialement,
zizou

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

Bonjour Frenchie83,
Je ne sais pas comment vous remercier, je prépare le fichier...
Cdlt,
zizou

Réponse 3 / 7

Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 337
27 sept. 2020 à 16:39

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

Réponse 4 / 7

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1
17 sept. 2020 à 21:07

Bonsoir Mike-31,
j'aurais aimer en VBA c'est possible?
Merci par avance,
zizou

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

Posez votre question

Réponse 5 / 7

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1
27 sept. 2020 à 12:04

bonjour quelqu'un pourrait m'aider? SVP...

Réponse 6 / 7

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1
27 sept. 2020 à 15:15

Super, je te remercie beaucoup, c'est possible d'inclure la période (voir C2 & D2)?
Cordialement,
zizou

Réponse 7 / 7

zizou026 Messages postés 97 Date d'inscription dimanche 1 février 2009 Statut Membre Dernière intervention 14 octobre 2021 1
27 sept. 2020 à 16:44

C'est exactement ce qu'il me fallait ÉNORME MERCI.
Cordialement,
zizou

Discussions similaires

exo pix

Formule Excel : "SI" une cellule contient un mot, alors ?

je veut créer des codes

Discussions similaires

Newsletters