XL 2019 Borné une extraction par date

jui42

XLDnaute Junior
Bonjour,
J'ai une macros me permettant d'extraire des références de produits et de me mettre en surbrillance ceux pours lesquels un contrôle est à effectuer.
Désormais, j'aimerais préciser cette recherche en la bornant par date. Pour cela, je place deux input box dans mon programme qui me serviront de bornes mais je n'arrive pas a rechercher les produits correspondant à une date ENTRE ces deux dates.
Je met le ENTRE en majuscule car jusque là j'arrive uniquement à sélectionner les dates identiques à celles inscrites dans le inputbox.
Je vous joint le fichier ainsi que le code.
Merci pour votre temps,
VB:
Option Explicit
Option Compare Text



Sub Macro6()
'
' Macro6 Macro
   Dim Cell As Range
   ActiveSheet.Columns("A:E").ClearContents

'
    Sheets("excelexport").Select
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    Range("J:J,K:K,Q:Q").Select
    Range("Q1").Activate
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    Range("J:J,K:K,Q:Q,T:T").Select
    Range("T1").Activate
    Selection.Copy
    Sheets("planning de reception").Select
    Range("A1").Select
    ActiveSheet.Paste
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="(", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
        Columns("A:D").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
        Range("E1").Select
    ActiveCell.FormulaR1C1 = "Contrôle potentiel"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-4],liste!C[-3],1,FALSE)),""Pas de contrôle"",""Contrôle à effectuer"")"
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E360"), Type:=xlFillDefault
    Range("E2:E360").Select
    ActiveWindow.SmallScroll Down:=-399
    
    Columns("E:E").AutoFit
    Range("E1").Font.Bold = True
    ActiveSheet.Columns("E:E").Select
    Selection.HorizontalAlignment = xlCenter
    Selection.VerticalAlignment = xlCenter
                
    Selection.Borders.LineStyle = 1
    Selection.Borders.LineStyle = Excel.XlLineStyle.xlContinuous
    
  '  Range("E2").Select
    
    Range("A2:E400").EntireRow.Select
    Selection.FormatConditions.Add Type:=xlTextString, String:= _
        "Contrôle à effectuer", TextOperator:=xlContains
    Selection.EntireRow.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        
        
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    Dim Cellule As Range
    'Parcourir les cellules de la plage utilisée
    For Each Cellule In ActiveSheet.UsedRange
'Traiter uniquement les cellules possédant une formule
    If Cellule.HasFormula Then
        Cellule.Formula = Cellule.Value
    End If
    Next Cellule
        Dim kam As String
        kam = "Contrôle à effectuer"
    
    
        Dim FirstFound As String        ' definition des variable que l'on va utiliser
        Dim FoundCell As Range, rng As Range
        Dim myRange As Range, LastCell As Range
        
        'Valeur a chercher cb1
        
        Set myRange = ActiveSheet.UsedRange.Columns(5)
        Set LastCell = myRange.Cells(myRange.Cells.Count)
        Set FoundCell = myRange.Find(what:=kam, After:=LastCell)

        'Test pour voir si qlq chose est trouver
        If Not FoundCell Is Nothing Then
            FirstFound = FoundCell.Address
            
        Else
            
            GoTo NothingFound
        End If
        
        Set rng = FoundCell
        ' TEST POUR EMPECHER L'ERREUR SUR LA VALEUR TROUVEE
        
        'Tour jusqu'a que ça trouve tout
        Do Until FoundCell Is Nothing
            'Trouve la nouvelle cellule avec la valeur
            Set FoundCell = myRange.FindNext(After:=FoundCell)
            
            'Ajoute la valeur a la variable tableau
            Set rng = Union(rng, FoundCell)
            
            'Test pour sortir de la boucle
            If FoundCell.Address = FirstFound Then Exit Do
            'loop va recommencer la boucle
        Loop
        
        'selection du tableau
        rng.EntireRow.Select
        Selection.Interior.ColorIndex = 6
        
        Dim Ws1 As Worksheet
        Dim Ws2 As Worksheet
        Set Ws1 = Sheets("planning de reception")
        Set Ws2 = Sheets("excelexport")
        
        
        Ws1.Activate
        Dim date1 As String
        Dim date2 As String
        
        
        Do
            date1 = InputBox("Saisir la date de au format jj/mm/aaaa", _
                "Date reception", Format(Date))
            If Len(date1) = 0 Then Exit Sub
            If IsDate(date1) Then Exit Do
                MsgBox "Date obligatoire"
        Loop
        
        Do
            date2 = InputBox("Saisir la date de au format jj/mm/aaaa", _
                "Date reception", Format(Date))
            If Len(date2) = 0 Then Exit Sub
            If IsDate(date2) Then Exit Do
                MsgBox "Date obligatoire"
        Loop
        
        Ws2.Activate
        
        

        Sheets("liste").Visible = 2
    
    Exit Sub
NothingFound:
    
    MsgBox ("Aucune valeur " & "        'a été trouvé. Veuillez réessayer")
    
 End Sub
 

Pièces jointes

  • CARNET_COMMANDE_20220428.xlsm
    99 KB · Affichages: 9

vgendron

XLDnaute Barbatruc
Hello

je me suis permis d'arranger ta macro
regarde les commentaires que j'y ai mis
VB:
Sub Macro6()

Dim Cell As Range
Dim LastLine As Long
Dim Zone As Range
Dim Cellule As Range

Dim kam As String
Dim FirstFound As String        ' definition des variables que l'on va utiliser
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim date1 As Date
Dim date2 As Date

With Sheets("planning de reception")
    .AutoFilterMode = False
End With

With Sheets("excelexport")
    .AutoFilterMode = False
End With

With Sheets("planning de reception")
   
     .Columns("A:E").Clear 'on efface les colonnes A à E (juste le contenu, pas les mises en forme éventuelles)
     Sheets("excelexport").Range("J:J,K:K,Q:Q,T:T").Copy Destination:=.Range("A1") 'copie des colonnes, J, K Q T
     LastLine = .UsedRange.Rows.Count 'on récupère le numéro de la dernière ligne
     .Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'insertion d'une colonne
    
     Application.DisplayAlerts = False 'on désactive les messages
     .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="(", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True 'conversion des données pour séparer
     Application.DisplayAlerts = True 'on réactive les messages
    .Columns("B:B").Delete Shift:=xlToLeft 'suppression de la colonne B
   
    'Mises en forme
    With .Columns("A:D").Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    .Range("E1") = "Contrôle potentiel" 'ecriture de l'entete
    .Range("E2").FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-4],liste!C[-3],1,FALSE)),""Pas de contrôle"",""Contrôle à effectuer"")" 'formule
   
    .Range("E2").AutoFill Destination:=.Range("E2:E" & LastLine), Type:=xlFillDefault 'on tire la formule jusqu'en bas
    .Columns("E:E").AutoFit 'Mise en forme
   
   
    .Range("E1").Font.Bold = True 'Mise en forme
    .Columns("E:E").HorizontalAlignment = xlCenter 'Mise en forme
    .Columns("E:E").VerticalAlignment = xlCenter 'Mise en forme
               
    .Columns("E:E").Borders.LineStyle = 1 'Mise en forme
    .Columns("E:E").Borders.LineStyle = Excel.XlLineStyle.xlContinuous 'Mise en forme
   

    Set Zone = .Range("A1:E" & LastLine) 'pourquoi prendre l'entirerow? et pas juste les données?
    Zone.FormatConditions.Delete
    Zone.FormatConditions.Add Type:=xlTextString, String:= _
        "Contrôle à effectuer", TextOperator:=xlContains
    Zone.FormatConditions(Zone.FormatConditions.Count).SetFirstPriority
    With Zone.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
    Zone.FormatConditions(1).StopIfTrue = False
   
End With

'Parcourir les cellules de la plage utilisée 'pour faire un Ctrl C / Ctrl V valeurs?
For Each Cellule In Zone
    'Traiter uniquement les cellules possédant une formule
    If Cellule.HasFormula Then
        Cellule.Formula = Cellule.Value
    End If
Next Cellule

kam = "Contrôle à effectuer"

Set myRange = Zone.Columns(5)
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=kam, After:=LastCell)
Zone.AutoFilter Field:=5, Criteria1:=kam
Zone.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 6


Set Ws1 = Sheets("planning de reception")
Set Ws2 = Sheets("excelexport")

Ws1.Activate
Do
    date1 = InputBox("Saisir la date de au format jj/mm/aaaa", "Date reception", Format(Date))
    If Len(date1) = 0 Then Exit Sub
    If IsDate(date1) Then Exit Do
    MsgBox "Date obligatoire"
Loop

Do
    date2 = InputBox("Saisir la date de au format jj/mm/aaaa", _
        "Date reception", Format(Date))
    If Len(date2) = 0 Then Exit Sub
    If IsDate(date2) Then Exit Do
    MsgBox "Date obligatoire"
Loop

With Ws2
    .AutoFilterMode = False
    .UsedRange.AutoFilter Field:=17, Criteria1:= _
        ">=" & CDbl(date1), Operator:=xlAnd, Criteria2:="<=" & CDbl(date2) 'on applique le filtre sur les dates
       
    'il suffit ensuite de copier coller le .usedrange.specialcells(xlcelltypevisible)
End With

Sheets("liste").Visible = 2

Exit Sub
NothingFound:

MsgBox ("Aucune valeur " & "        'a été trouvé. Veuillez réessayer")
   
 End Sub
 

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour,

Ci-joint une proposition par power query.
Si date début et date fin sont nulles, toutes les lignes sont retournées
Si date début et date fin ne sont pas nulles toutes les lignes entres les dates (incluses) sont retenues
Si date début seule n'est pas nulle les lignes à partir de date début sont incluses
si date fin seule n'est pas nulle les lignes jusqu'à date fin sont retenues

Cordialement
 

Pièces jointes

  • PQ-CARNET_COMMANDE_20220428.xlsm
    110.6 KB · Affichages: 10

Hasco

XLDnaute Barbatruc
Repose en paix
Re,
Oui, comme le dit @Deadpool_CC c'est une requête Power Query.
Sélectionnez une cellule du tableau de résultat,
Sur l'onglet de ruban 'Requête' qui s'affiche alors, à droite vous avez un bouton 'Modifier',
Cliquez sur ce bouton et l'éditeur PQ s'ouvrira.

Dans le volet gauche de l'éditeur vous aurez la liste des requêtes du classeurs.
RQ_Contrôles, requête finale qui sélectionne les lignes à partir du tableau structuré de la feuille 'excelexport'
Sélectionnez cette requête en cliquant sur son nom
Dans le panneau de droite vous verrez apparaître les différentes étapes de transformation des données.
Dans le panneau central sera afficher un aperçu de l'état actuel des données (état de l'étape sélectionnée dans le panneau de droite.
Au-dessus de ce panneau central vous trouvez la barre de formule de PQ. Si elle n'est pas affichée, allez dans l'onglet 'Affichage' et à droite de ce dernier vous cocherez la case 'Barre de formule'.
Cette barre de formule permet de construire des étapes que l'interface et ses déjà nombreuses possibilités ne permet pas, ou de modifier les étapes construites par l'interface.

La requête 'Dates' permet de récupérer les dates de la plage de cellules nommée 'Param_Dates' (C1:C2 de la feuille 'Contrôles')
La requête 'T_Liste_Contrôles' récupère le tableau structuré de la feuille 'Liste'.

Ces deux dernières requêtes sont utilisées par la requête principale 'RQ_Contrôles' afin de sélectionner les lignes entre dates pour la première (étape : Dates sélectionnées) et pour l'ajout de la colonne de tests( étape : Test contrôle)

Baladez-vous dans les différentes étapes, voyez ce que cela renvoie dans la barre de formule. vous pouvez développer celle-ci par sa flèche sur son extrême droite.

J'ai attendu de voir si vous étiez intéressé par cette solution avant de rédiger ses explications :)
Cherchez des tutos sur internet et revenez avec vos difficultés.

cordialement
 

Phil69970

XLDnaute Barbatruc
Bonjour le fil

@jui42

Je te propose ce fichier revu à ma sauce, un peu à la bourre mais le soleil avant tout !!! ;)

Par contre :
J'ai pas compris dans quelle feuille il faut filtrer et ce que tu veux faire ?
Donc si tu veux la suite , explique nous ce que tu veux....

*Merci de ton retour

@Phil69970
 

Pièces jointes

  • Carnet commandes avec MFC V1.xlsm
    104.8 KB · Affichages: 5

Phil69970

XLDnaute Barbatruc
Bonjour à tous

@jui42
Ok pour le filtre
le filtre doit se faire sur la feuille "planning de réception"

Et tu veux afficher tous les lignes qui correspondantes aux 2 dates que l'on met dans l'inputbox ou tu veux autres choses.

Exemple ici : 09/05/2022 et 03/03/2022

1655708990160.png


Explique bien et avec des exemples de ce que tu veux faire ET avec le résultat à obtenir.....
Plus c'est clair mieux c'est pour la compréhension

Je viens de regarder ton fichier
Et alors , ça fonctionne et cela correspond à ce que tu veux ?

@Phil69970
 

jui42

XLDnaute Junior
Re,
Du coup, j'ai essayé d'appliqué le filtre sur ma feuille "planning de réception" mais rien ne se passe.
Je ne vois pas trop comment je pourrais faire
VB:
Sub Macro6()
Application.ScreenUpdating = False
Dim Sh1 As Worksheet, Sh2 As Worksheet, DerligSrc&, DerligDst& ', Plage As Range
Dim i&
Set Sh1 = Sheets("excelexport"): Set Sh2 = Sheets("planning de reception")  'Nom à adapter en cas de changement noms des onglets
DerligSrc = Sh1.Range("J" & Rows.Count).End(xlUp).Row

With Sh2
    'La copie des données
    .Range("A1:B" & DerligSrc) = Sh1.Range("J1:K" & DerligSrc).Value
    .Range("C1:C" & DerligSrc) = Sh1.Range("Q1:Q" & DerligSrc).Value
    .Range("D1:D" & DerligSrc) = Sh1.Range("T1:T" & DerligSrc).Value
    
    'Suppression des parenthese et des valeurs associés
    For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
        If InStr(.Range("A" & i).Value, "(") <> 0 Then _
            .Range("A" & i).Value = Trim(Split(.Range("A" & i).Value, "(")(0))
    Next i
    
    'Ajout de la colonne E
    .Range("E1") = "Contrôle potentiel"
    .Range("E2").FormulaLocal = "=SI(ESTNA(RECHERCHEV(A2;liste!B:B;1;FAUX));""Pas de contrôle"";""Contrôle à effectuer"")"
    
    'Remplissage de la colonne E
    DerligDst = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("E2").AutoFill Destination:=.Range("E2:E" & DerligDst), Type:=xlFillCopy
    .Range("E2:E" & DerligSrc) = .Range("E2:E" & DerligSrc).Value

    'Mise en formes des données
    .Columns("A:E").AutoFit
    .Range("A1:E1").Font.Bold = True
    .Range("A1:E" & DerligDst).HorizontalAlignment = xlCenter
    .Range("A1:E" & DerligDst).VerticalAlignment = xlCenter
    .Range("A1:E" & DerligDst).Borders.LineStyle = 1
    
    'Mise en place de la MFC
    .Cells.FormatConditions.Delete
    .Range("A2:E" & DerligDst).FormatConditions.Add Type:=xlExpression, Formula1:="=$E2=" & """Contrôle à effectuer"""
    .Range("A2:E" & DerligDst).FormatConditions(1).Interior.Color = rgbYellow   'Couleur de la MFC
End With

Application.ScreenUpdating = True

Dim MaDate1 As Date, MaDate2  As Date, Reponse As String

Do While Not IsDate(Reponse)
    Reponse = InputBox("Saisir la date de au format jj/mm/aaaa " & Chr(13) & Chr(10) & "ou annuler l'opération" & Chr(13) & Chr(10) & "Si vide = annulé ", "Date reception 1")
    If Reponse = "" Then MsgBox "Vous avez annulé !", vbCritical, "Au revoir...": Exit Sub
Loop
MaDate1 = Reponse: Reponse = ""

Do While Not IsDate(Reponse)
    Reponse = InputBox("Saisir la date de au format jj/mm/aaaa " & Chr(13) & Chr(10) & "ou annuler l'opération" & Chr(13) & Chr(10) & "Si vide = annulé ", "Date reception 2")
    If Reponse = "" Then MsgBox "Vous avez annulé !", vbCritical, "Au revoir...": Exit Sub
Loop
MaDate2 = Reponse
'J'ai pas compris dans quelle feuille il faut filtrer et ce que tu veux faire ?
'Donc si tu veux la suite , explique nous ce que tu veux....
With Sh2

    .Range("C1").AutoFilter Field:=1, Criteria1:= _
                            ">=" & MaDate1, Operator:=xlAnd, _
                            Criteria2:="<=" & MaDate2
                            
                            
                            
                            
    
End With
Sheets("liste").Visible = 2
End Sub
 

job75

XLDnaute Barbatruc
Bonjour jui42, le fil,

Avec le filtre avancé le code dans la feuille "planning de reception" est très simple :
VB:
Private Sub Worksheet_Activate()
Worksheet_Change [Début] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Début:Fin]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("A2:E" & Rows.Count).Delete xlUp 'RAZ
With Sheets("excelexport")
    .[W2] = "=AND(Q2>=Début,Q2<=Fin)" 'critère
    .[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[W1:W2], [A1:D1] 'copie le filtre avancé
End With
Range("A2:E" & Rows.Count).WrapText = False
Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone
[A1].CurrentRegion.Columns(5) = "=IF(COUNTIF(liste!B:B,A1),""Contrôle à efectuer"",""Pas de contrôle"")"
[E1] = "Contrôle"
End Sub
Il se déclenche quand on modifie ou valide les dates en G2 ou H2 ou qu'on active la feuille.

A+
 

Pièces jointes

  • CARNET_COMMANDE(1).xlsm
    99.1 KB · Affichages: 6

Discussions similaires

Statistiques des forums

Discussions
311 740
Messages
2 082 047
Membres
101 880
dernier inscrit
Anton_2024