Déplacer une flèche selon le numéro de semaine

Bonjour,

Je suis nouvelle sur le forum. Je me permets de vous écrire car j'ai besoin de votre aide.

Je vous joint mon fichier Excel où on retrouve un planning à la semaine pour l'année. Je souhaite insérer une flèche qui se déplace automatiquement toute seule selon le numéro de la semaine. La flèche permettra de savoir où on se situe et sans qu'on soit à chaque fois obligé de la déplacer manuellement. Ç'est un fichier collectif, et automatiser la flèche permettrait d'éviter les oublis de déplacement.

J'ai inséré la flèche mais je ne sais pas comment lui dire, par exemple: Aujourd'hui (12/01/2021) = Semaine 2 donc mettre la flèche visant la semaine 2 etc...

J'espère avoir été assez clair. Merci d'avance pour votre aide.

Bonsoir MadierSa et bienvenue, bonsoir le forum,

le code ne fait pas exactement ce que tu demandes car la flèche n'est pas déplacée mais la colonne de la semaine en cours se trouve affichée en premier.

Le code se trouve dans ThisWorkbook :

Option Explicit

Private Sub Workbook_Open()
Module1.Macro1
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "NUIT" Then Module1.Macro1
End Sub

et dans le Module1 :

Option Explicit

Sub Macro1()
Dim N As Worksheet
Dim R As Range

Set N = Sheets("NUIT")
N.Activate
Set R = N.Rows(5).Find("Semaine " & Application.WorksheetFunction.WeekNum(Date), , xlValues, xlWhole)
If Not R Is Nothing Then ActiveWindow.ScrollColumn = R.Column
End Sub

Le fichier :

Bonjour,

Merci beaucoup pour votre aide.

L'idée me plaît, par contre pour Excel, on se situe en "Semaine 3" hors nous on utilise le calendrier pour suivre les semaines et actuellement on est en Semaine 2. Est-ce qu'il a possibilité de faire -1 ? De plus, au lieu de mettre une flèche, je peux éventuellement colorer la bordure. Mais comment l'écrire en VBA ?

C'est-à-dire, on est en Semaine 3 donc mettre la bordure "Semaine 3" en rouge.

Pensez-vous que ce soit possible?

Merci d'avance

Re,

Nouvelle proposition. Remplace le code du Module1 par celui-ci :

Option Explicit

Sub Macro1()
Dim N As Worksheet
Dim R As Range

Set N = Sheets("NUIT")
N.Activate
Set R = N.Rows(5).Find("Semaine " & Application.WorksheetFunction.WeekNum(Date) - 1, , xlValues, xlWhole)
If Not R Is Nothing Then ActiveWindow.ScrollColumn = R.Column
With R.Offset(0, -1).Resize(10, 1)
    With .Borders(xlEdgeTop)
        .ColorIndex = 0
    End With
    With .Borders(xlEdgeLeft)
        .ColorIndex = 0
    End With
    With .Borders(xlEdgeRight)
        .ColorIndex = 0
    End With
    With .Borders(xlEdgeBottom)
        .ColorIndex = 0
    End With
End With
With R.Resize(10, 1)
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -16777024
    End With
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -16777024
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -16777024
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -16777024
    End With
End With
End Sub

Bonsoir …

commande (Cmd*) pour déplacer la flèche (nommée ici Fl) selon le numéro de semaine

Private Sub Cmd_Click()
    Dim c As Integer, x As Byte
    x = Application.RandBetween(1, 52)    'ou autre ... comme x = …
    MsgBox "semaine " & x                 'pour voir seulement où aller
    c = Rows(5).Find("Semaine " & x, MatchCase:=1).Column
    Cells(5, c).Select
    Me.Shapes("fl").Left = Cells(1, c).Left + 20
End Sub

*pas de recherche ans le Classeur entier pour connaître d’abord le N° sauf s c’est celui de la semaine courante et là, Tauthème (salut) en a donné la ligne de commande

Re,

Ordonc ! Trop fort ! J'suis vert...

Je me permet juste d'adapter son code à ton fichier MadierSa :

Private Sub Cmd_Click()
Dim N As Worksheet
Dim C As Byte

Set N = Worksheets("NUIT")
N.Activate
C = N.Rows(5).Find("Semaine " & Application.WorksheetFunction.WeekNum(Date), , xlValues, xlWhole).Column - 1
Cells(5, C).Select
Sheets("NUIT").Shapes("Down Arrow 2").Left = Cells(1, C).Left + 20
End Sub