Bonjour,
Je souhaite que cela remplisse un autre onglet car le fichier est composé de plusieurs onglet de différents matériels (10 avec plusieurs ligne) et que chaque semaine je dois tous extraire et l'envoyer à d'autres personnes.
Dans mon fichier présent, il s'agit d'un bout du fichier , je n'ai pas voulu mettre la totalité car trop lourd et sans intérêt car indique pour chaque onglet.
Merci de ton aide
Voici le code complet
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C3:C50")) Is Nothing Then
Cancel = True
'Récupération des données de la ligne choisie
xDesigna = Cells(Target.Row, "A")
xReferen = Cells(Target.Row, "B")
xNomAjus = Cells(Target.Row, "C")
xDatePre = Cells(Target.Row, "D")
xManquan = Cells(Target.Row, "F")
xStatut = Cells(Target.Row, "E")
'Test si un ajusteur est déja indiqué
If xNomAjus <> Empty Then
xMess = Empty
xMess = xMess & "L'ajusteur " & xNomAjus & " est déjà indiqué" & Chr(13)
xMess = xMess & "Cela veut-il dire qu'il à rendu le matériel" & Chr(13) & Chr(13)
xMess = xMess & " - Si OUI, matériel rendu, donc effacement des données" & Chr(13)
xMess = xMess & " - Si NON, erreur de ligne" & Chr(13)
xRep = MsgBox(xMess, vbQuestion + vbYesNo, "TOTO")
If xRep = vbYes Then
Cells(Target.Row, "C") = Empty
Cells(Target.Row, "D") = Empty
xStatut = "Rendu"
Cells(Target.Row, "E") = ""
GoTo EnregistreHistorique
Else
Exit Sub
End If
Else
xNomAjus = InputBox("Nom de l'ajusteur", "AJUSTEUR")
Cells(Target.Row, "C") = xNomAjus
Cells(Target.Row, "D") = Now
xDatePre = Cells(Target.Row, "D")
xStatut = "Emprunté"
Cells(Target.Row, "E") = xStatut
End If
EnregistreHistorique:
With Sheets("HistoriquePrêt")
xDerLig = .Range("A65536").End(xlUp).Row
xNewlig = xDerLig + 1
.Cells(xNewlig, "A") = xDesigna 'Désignation
.Cells(xNewlig, "B") = xReferen 'Référence
.Cells(xNewlig, "C") = xNomAjus 'Nom ajusteur
.Cells(xNewlig, "D") = Now 'Date pret
.Cells(xNewlig, "F") = xManquan 'Manquant
.Cells(xNewlig, "E") = xStatut 'Statut
End With
End If
End Sub
Sub retard()
For Each Cel In Range("D3
" & Range("D" & Rows.Count).End(xlUp).Row)
If Cel.Value <> "" Then
r = Cel.Row
late = Now - Cel.Value
If late > CDate("10:00") Then
Rows(r).EntireRow.Copy
derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1
MsgBox derlig
Sheets("Retard").Range("A2:E" & Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row).ClearContents
End If
End If
Next Cel
End Sub