Formule recherche VBA
Résolu
zizou026
Messages postés
101
Date d'inscription
Statut
Membre
Dernière intervention
-
zizou026 Messages postés 101 Date d'inscription Statut Membre Dernière intervention -
zizou026 Messages postés 101 Date d'inscription Statut Membre Dernière intervention -
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
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 si et - Guide
- Recherche automatique des chaînes ne fonctionne pas - Guide
- Formule moyenne excel plusieurs colonnes - Guide
- Formule mathématique - Télécharger - Études & Formations
- Formule somme excel colonne - Guide
7 réponses
Bonjour,
tu peux faire avec une formule
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<>""))
Bonjour,
Essayez ceci
https://mon-partage.fr/f/pH0RtFBu/
le code
Cdlt
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
Bonjour,
Voici, mais je n'ai pas testé
Option Explicit
Cdlt
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
Voilà
Cdlt
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
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question