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

jui42

XLDnaute Junior
Re,
J'ai donc pu faire a peu près ce que je voulais c'est à dire que j'extrait des donnée auxquels j'applique une MFC et un encadrement par date.
@job75 j'utilise ta solution mais le soucis est que pour la suite de mon programme je dois supprimer les lignes correspondantes à certaines référence ( celle qui contiennent "PROJ" et "FORF") j'arrive bien à le faire mais le problème est que cela supprime la sub privé que tu m'as faite. Aurais-tu une idée ?
 

Pièces jointes

  • CARNET_COMMANDE(1).xlsm
    96 KB · Affichages: 1

job75

XLDnaute Barbatruc
@job75 j'utilise ta solution
Pas du tout, ce n'est pas le code que j'ai donné.

Et il n'a jamais été question de copier la colonne "NumeroCommande".

Pour ne pas copier les lignes contenant "PROJ" ou "FORF" il suffit de modifier le critère, fichier (2) :
VB:
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,COUNTIF(J2:K2,""*PROJ*"")=0,COUNTIF(J2:K2,""*FORF*"")=0)" '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 à effectuer"",""Pas de contrôle"")"
[E1] = "Contrôle"
End Sub
 

Pièces jointes

  • CARNET_COMMANDE(2).xlsm
    99.3 KB · Affichages: 1

jui42

XLDnaute Junior
Re @job75
Une dernière question stp,
Jai un peu modifié le code que tu m'as donné mais je n'ai aucune idée de comment tu extrait les données du fichier "excelexport". Car j'ai besoin de la colonne numéro de commande. Je te joint le code que j'ai modifié.
VB:
Option Explicit

Private Sub Worksheet_Activate()
Worksheet_Change [Début] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
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,COUNTIF(J2:K2,""*MOUL*"")=0,COUNTIF(J2:K2,""*PROJ*"")=0,COUNTIF(J2:K2,""*FORF*"")=0)" '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
With Sheets("planning de reception")
    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
End With
[A1].CurrentRegion.Columns(5) = "=IF(COUNTIF(liste!B:B,A1),""Contrôle à effectuer"",""Pas de contrôle"")"
[E1] = "Contrôle"


Dim Sh1 As Worksheet, Sh2 As Worksheet, DerligSrc&, DerligDst&

Set Sh1 = Sheets("excelexport"): Set Sh2 = Sheets("planning de reception")

DerligSrc = Sh1.Range("A" & Rows.Count).End(xlUp).Row

With Sh2


    'Mise en formes des données
    .Columns("A:E").AutoFit
    .Range("A1:E1").Font.Bold = True
    DerligDst = .Range("A" & Rows.Count).End(xlUp).Row
    .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

End Sub
 

Pièces jointes

  • CARNET_COMMANDE(2).xlsm
    96.4 KB · Affichages: 0

job75

XLDnaute Barbatruc
Ce n'est pas un problème d'ajouter la colonne "NumeroCommande", voyez ce fichier (3) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Début:Fin]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).Delete xlUp 'RAZ
With Sheets("excelexport")
    .[W2] = "=AND(Q2>=Début,Q2<=Fin,COUNTIF(J2:K2,""*PROJ*"")=0,COUNTIF(J2:K2,""*FORF*"")=0)" 'critère
    .[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[W1:W2], [A1:E1] 'copie le filtre avancé
End With
Range("A2:F" & Rows.Count).WrapText = False
Range("A2:F" & Rows.Count).Interior.ColorIndex = xlNone
[A1].CurrentRegion.Columns(6) = "=IF(COUNTIF(liste!B:B,A1),""Contrôle à effectuer"",""Pas de contrôle"")"
[F1] = "Contrôle"
End Sub
Re @job75
je n'ai aucune idée de comment tu extrait les données du fichier "excelexport".
Documentez-vous sur le filtre avancé et l'argument xlFilterCopy.
 

Pièces jointes

  • CARNET_COMMANDE(3).xlsm
    99.4 KB · Affichages: 3

jui42

XLDnaute Junior
Ce n'est pas un problème d'ajouter la colonne "NumeroCommande", voyez ce fichier (3) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Début:Fin]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).Delete xlUp 'RAZ
With Sheets("excelexport")
    .[W2] = "=AND(Q2>=Début,Q2<=Fin,COUNTIF(J2:K2,""*PROJ*"")=0,COUNTIF(J2:K2,""*FORF*"")=0)" 'critère
    .[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[W1:W2], [A1:E1] 'copie le filtre avancé
End With
Range("A2:F" & Rows.Count).WrapText = False
Range("A2:F" & Rows.Count).Interior.ColorIndex = xlNone
[A1].CurrentRegion.Columns(6) = "=IF(COUNTIF(liste!B:B,A1),""Contrôle à effectuer"",""Pas de contrôle"")"
[F1] = "Contrôle"
End Sub

Documentez-vous sur le filtre avancé et l'argument xlFilterC
J'obtient une erreur à la ligne .[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[W1:W2], [A1:E1] 'copie le filtre avancé "Le nom de champ est incorrect ou manquant dans la zone d'extraction"
 

Discussions similaires

Réponses
13
Affichages
605

Statistiques des forums

Discussions
302 039
Messages
1 999 913
Membres
214 703
dernier inscrit
christophe.dubreuil.ghi