Bonjour à tous,
Voici la dernière mouture...
Maintenant tu dois renseigner l'Identifiant en premier, cela "active" la ligne. Ensuite tu dois renseigner le Lieu ET le Pointage MÊME si c'est celui qui est déjà en place. (notre ami Hascodevrait pouvoir régler ça en incluant un And dans son code : If Not Intersect(Target, Range("Pointage").Columns(6)) AND If Not Intersect(Target, Range("Pointage").Columns(1)) Is Nothing...) peut-être
J'ai rajouté un bouton Archive : le fichier prend le nom du mois en B1 de la feuille Salaire.
A+
Bonjour à tous,
Salut Ali,
Tu as entièrement raison notre joli tableur (dantesque arf BH²) n'est pas suffisamment "performant"....
Bonjour à tous,
J'ai renvoyé le fichier à notre ami.
Modification :
* Suppression des =Pointage!$A7 et suivant en feuille Salaire, mise en "dur" des Identifiants à partir de la feuille Data
*Ajout d'un petit code pour mettre 1, en $J$6:$AN$459 de la feuille Salaire, par défaut lors de l'Archivage et donc sur le nouveau fichier créé
*Pas de modification du code d'Hasco qui continue à bien tourner malgré les formules rajoutées en $J$6:$AN$459 de la feuille Salaire mais qui se trouvent écrasées par son code
A+ à tous
Et surement à bientôt, connaissant notre ami Ali arf arf
Option Explicit
Dim bCondition As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If Not bCondition And Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("Pointage").Columns(6)) Is Nothing Then
Dim NumColSalaire As Long
Dim Ref As Variant
Dim i As Long
Dim c As Range
For i = 1 To Target.Rows.Count
Ref = Cells(Target.Rows(i).Row, 1)
If Ref = 0 Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
With Sheets("Salaire")
Set c = .Range("D6", Sheets("Salaire").Range("D6").End(xlDown)).Find(What:=Ref, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
NumColSalaire = .Range("J3").Column + Day(Range("DatePointage")) - 1
.Cells(c.Row, NumColSalaire) = Target.Cells(1, 1)
Else
.Cells(.Row, NumColSalaire) = 1
End If
End With
Application.EnableEvents = True
On Error GoTo 0
Next i
ElseIf Not Intersect(Target, Range("DatePointage")) Is Nothing Then
Dim DerLigne As Long
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
Range("B2") = "Mise à jour en cours...Patientez..."
Application.Calculation = xlCalculationManual
bCondition = True
If DerLigne > 6 Then Range("F7:F" & DerLigne).Value = 1
bCondition = False
Application.Calculation = xlCalculationAutomatic
Range("B2") = ""
End If
End Sub
Bonjour JiChiali,
Salut JC,
Voici une proposition pour que tous les lignes de pointage (colonne F) se mette à 1 lorsque l'on change le jour dans 'Pointage'!B2
Comme la mise à jour est également faite sur salaire (Si les références idoines existent dans la feuille) cela mets 3 à 4 secondes pour 480 Lignes.
Ne sachant pas où t'envoyer le fichier xls (trop volumineux et données confidentielles) je mets ci-dessous le texte à remplacer pour le code de la feuille Pointage.
Bonne soirée à vous toutes et tous.Code:Option Explicit Dim bCondition As Boolean Private Sub Worksheet_Change(ByVal Target As Range) If Not bCondition And Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("Pointage").Columns(6)) Is Nothing Then Dim NumColSalaire As Long Dim Ref As Variant Dim i As Long Dim c As Range For i = 1 To Target.Rows.Count Ref = Cells(Target.Rows(i).Row, 1) If Ref = 0 Then Exit Sub On Error Resume Next Application.EnableEvents = False With Sheets("Salaire") Set c = .Range("D6", Sheets("Salaire").Range("D6").End(xlDown)).Find(What:=Ref, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then NumColSalaire = .Range("J3").Column + Day(Range("DatePointage")) - 1 .Cells(c.Row, NumColSalaire) = Target.Cells(1, 1) Else .Cells(.Row, NumColSalaire) = 1 End If End With Application.EnableEvents = True On Error GoTo 0 Next i ElseIf Not Intersect(Target, Range("DatePointage")) Is Nothing Then Dim DerLigne As Long DerLigne = Range("A" & Rows.Count).End(xlUp).Row Range("B2") = "Mise à jour en cours...Patientez..." Application.Calculation = xlCalculationManual bCondition = True If DerLigne > 6 Then Range("F7:F" & DerLigne).Value = 1 bCondition = False Application.Calculation = xlCalculationAutomatic Range("B2") = "" End If End Sub
Sub ArchivageFeuilleSalaire()
Dim Wkb As Workbook
Dim LaDate As String
On Error GoTo FinArchivage
Application.ScreenUpdating = False
'Création du nouveau classeur
Set Wkb = Workbooks.Add
' Avec ce classeur
With ThisWorkbook
LaDate = Format(.Sheets("Pointage").Range("B1").Value, "yyyy_mm")
.Sheets("Salaire").UsedRange.Copy
End With
'Avec le nouveau classeur
With Wkb
With .Sheets(1) ' avec sa feuille 1
With .Range("A1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
.Name = "Salaire"
.Range("A3:AQ3").EntireColumn.AutoFit
End With
.SaveAs Filename:=ThisWorkbook.Path & "\Gestion_Ali_" & LaDate & ".xls"
.Close
End With
'Mettre les valeurs de la feuille 'Salaire' à blanc
Sheets("Salaire").Range("J6:AN459").ClearContents
FinArchivage:
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub