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,
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
