XL 2010 Archivage en fonction d'une cellule avec formule

[Onil62]

Bonjour,

Merci de m'accepter dans votre communauté pour mon premier post.

Voilà, je vous sollicite parce que je n'y connais quasiment rien en VBA.
J'ai un tableau excel qui nous permet, lors d'une réunion hebdomadaire, de gérer et figer l'affectation de nos compagnons sur les différents chantiers en cours pour la semaine suivante.
Les conducteurs de travaux ont accès à ce tableau tout au long de la semaine pour anticiper leurs besoins en personnel.
Grace à un code récupéré sur un forum que j'ai adapté à nos besoins, je peux archiver les données en fin de réunion en cliquant sur le bouton "ARCHIVAGE".
Après avoir cliqué sur ce bouton, l'archivage est bloqué tant que la date en "A1" n'a pas changé.
Tout cela fonctionne très bien tant que je change la date en "A1" manuellement, le problème est que dans cette cellule j'ai mis une formule de rechercheH qui me permet de récupérer une date spécifique dans le tableau et la ça ne marche plus malgré que la formule de recherche fonctionne.

Est ce que quelqu'un pourrait m'aider à résoudre ce problème svp?

D'avance Merci,

Cordialement,


Private Sub ARCHIVAGE_Click()
Dim Derlig As Long
Dim X As Byte
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet

Set Sh1 = Worksheets("FEUILLE DE CALCUL")
Set Sh2 = Worksheets("ARCHIVAGE")
Set Sh3 = Worksheets("TABLEAU MO")

If Not Sh3.Range("A6").Text = "Les données de la semaine sont archivées" Then
Derlig = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
Sh2.Cells(Derlig, 1) = Sh3.Range("A1").Value
Sh2.Cells(Derlig, 1) = Sh3.Range("A1").Value
Sh2.Cells(Derlig, 1).NumberFormat = "dd/mm/yyyy"
Sh2.Cells(Derlig, 2) = Sh1.Range("Z3").Value
Sh2.Cells(Derlig, 3) = Sh1.Range("Z4").Value
Sh2.Cells(Derlig, 4) = Sh1.Range("Z5").Value
Sh2.Cells(Derlig, 5) = Sh1.Range("Z6").Value
Sh2.Cells(Derlig, 6) = Sh1.Range("Z7").Value
Sh2.Cells(Derlig, 7) = Sh1.Range("Z8").Value
Sh2.Cells(Derlig, 8) = Sh1.Range("Z9").Value
Sh2.Cells(Derlig, 9) = Sh1.Range("Z10").Value
Sh2.Cells(Derlig, 10) = Sh1.Range("Z11").Value
Sh2.Cells(Derlig, 11) = Sh1.Range("Z12").Value
Sh2.Cells(Derlig, 12) = Sh1.Range("Z13").Value
Sh2.Cells(Derlig, 13) = Sh1.Range("Z14").Value
Sh2.Cells(Derlig, 14) = Sh1.Range("Z15").Value
Sh2.Cells(Derlig, 15) = Sh1.Range("Z16").Value
Sh2.Cells(Derlig, 16) = Sh1.Range("Z17").Value
Sh2.Cells(Derlig, 16).NumberFormat = "0.0"
Sh3.Range("A6") = "Les données de la semaine sont archivées"
Else
MsgBox " Ces données sont déjà archivées. "
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then Range("A6").ClearContents
End Sub

 

[job75]

Bonjour Onil62, bienvenue sur XLD,

Le recalcul de la formule en A1 ne permet pas de déclencher la macro Worksheet_Change.

Quelle est exactement la formule qui se trouve en A1 ?

A+

 

[Onil62]

Bonjour job75,

Merci pour ta réactivité

Ci-dessous la formule en "A1":

=SI(RECHERCHEH(AUJOURDHUI()+5;H12:BI12;1)


A+

 

[job75]

Avec cette formule A1 ne se modifie pas, donc votre problème n'a pas de sens, sauf :

- quand AUJOURDHUI() change, donc a priori à l'ouverture du fichier le lendemain

- quand la plage H12:BI12 est modifiée : que faites-vous donc avec ces cellules ?

 

[Onil62]

Bonjour,

Effectivement j'ai copié qu'une partie de la formule, voici la formule complété qui change à l'ouverture du fichier quant la date correspond :
=SI(RECHERCHEH(AUJOURDHUI()+5;H12:BI12;1)="";"";RECHERCHEH(AUJOURDHUI()+5;H12:BI12;1))

La plage de cellules H12:BI12 ne change pas, elle contient les dates des 52 ou 53 lundi de l'année.

L'archivage nous est utile parce que une partie du personnel n'est pas présente tout au long de l'année (intérimaires, personnel venant temporairement d'autres agence etc...) et de ce fait on veut garder une trace de leur passage.

 

[job75]

Bonjour Onil62,

La formule =RECHERCHEH(AUJOURDHUI()+5;H12:BI12;1) se suffit à elle-même, le test est inutile.

Donc A1 sera modifiée uniquement le lendemain à l'ouverture du fichier.

Pour que la cellule A6 soit alors effacée il faut placer dans ThisWorkbook :

Private Sub Workbook_Open()
If Format(Date, "dd/mm/yyyy") = CStr([Date]) Then Exit Sub
Me.Names.Add "DATE", Format(Date, "dd/mm/yyyy") 'nom défini
Sheets("ARCHIVAGE").[A6].ClearContents 'nom de feuille à adapter au besoin
Me.Save 'enregistrement
End Sub

Bien sûr supprimer la macro Worksheet_Change.

A+

 

[Onil62]

Bonjour job75,

Je te remercie car mon projet avance, grâce à ton code la cellule A6 s'efface comme voulu.
Par contre est-ce possible que A6 s'efface lorsque A1 se modifie et non pas tous les jours comme actuellement avec ce code?

 

[job75]

Bonjour Onil62,

Par contre est-ce possible que A6 s'efface lorsque A1 se modifie et non pas tous les jours comme actuellement avec ce code?

Il faudrait que A1 se modifie or ce n'est pas le cas :

Avec cette formule A1 ne se modifie pas, donc votre problème n'a pas de sens, sauf :

- quand AUJOURDHUI() change, donc a priori à l'ouverture du fichier le lendemain

- quand la plage H12:BI12 est modifiée : que faites-vous donc avec ces cellules ?

A+

 

[Onil62]

Ok

Merci

 

[job75]

Cela dit à minuit A1 sera recalculée car la formule avec AUJOURDHUI() est volatile.

Si l'on veut qu'à minuit A6 soit effacée sans qu'on ait à fermer et rouvrir le fichier compléter ainsi :

Private Sub Workbook_Open()
If Format(Date, "dd/mm/yyyy") = CStr([Date]) Then Exit Sub
Me.Names.Add "DATE", Format(Date, "dd/mm/yyyy") 'nom défini
Sheets("ARCHIVAGE").[A6].ClearContents 'nom de feuille à adapter au besoin
Me.Save 'enregistrement
End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
If Format(Date, "dd/mm/yyyy") <> CStr([Date]) Then Workbook_Open
End Sub

 

[Onil62]

La formule en cellule A1 étant "=RECHERCHEH(AUJOURDHUI()+5), elle se modifie bien lorsqu'elle trouve la bonne date dans la plage de cellulles H12:BI12 à l'ouverture du fichier et dès que l'on clique sur n'importe quelle cellule.

 

[job75]

et dès que l'on clique sur n'importe quelle cellule.

Je ne vois pas comment ce que vous dites peut se produire.

 

[Onil62]

Je viens de faire un test, je vous assure que ça fonctionne