1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
|
Sub Test()
Dim Fe As Worksheet
Dim Plage As Range
Dim Cel As Range
Dim Tbl() As String
Dim Img As Shape
Dim NumSem As Integer
Dim NomImg As String
Dim Trouve As Boolean
Dim I As Integer
'adapter le nom de la feuille
Set Fe = Worksheets("Feuil1")
'défini la plage sur la ligne 1 où se trouvent les dates de chaque jours. Impératif, les dates doivent être des dates valides !!!
With Fe: Set Plage = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)): End With
'suppression de toutes les images
For Each Img In Fe.Shapes: Img.Delete: Next Img
'effectue la recherche de la date pour connaître la position de la cellule correspondant au numéro de semaine
For Each Cel In Plage
If Format(Cel.Value, "WW", vbMonday) = Format(Date, "WW", vbMonday) Then
'défini les zones devant recevoir les images (7 jours)
I = I + 1: ReDim Tbl(1 To 2, 1 To 8)
Tbl(1, 1) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, -14).Address
Tbl(1, 2) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, -7).Address
Tbl(1, 3) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Address
Tbl(1, 4) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, 7).Address
Tbl(1, 5) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, 14).Address
Tbl(1, 6) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, 21).Address
Tbl(1, 7) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, 28).Address
Tbl(1, 8) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Offset(, 35).Address
'Set Zone = Range(Cel.Offset(4), Cel.Offset(4, 6))
Trouve = True
Exit For
End If
Next Cel
'si pas trouvé, fin mais ça veut dire que probablement une ou plusieurs dates ne sont pas valides
If Trouve = False Then Exit Sub
'défini le numéro de la semaine
NumSem = Format(Date, "WW", vbMonday)
'NomImg = "semaine" & NumSem
'concatène
Tbl(2, 1) = "semaine" & NumSem - 2
Tbl(2, 2) = "semaine" & NumSem - 1
Tbl(2, 3) = "semaine" & NumSem
Tbl(2, 4) = "semaine" & NumSem + 1
Tbl(2, 5) = "semaine" & NumSem + 2
Tbl(2, 6) = "semaine" & NumSem + 3
Tbl(2, 7) = "semaine" & NumSem + 4
Tbl(2, 8) = "semaine" & NumSem + 5
For I = 1 To 8
On Error Resume Next 'gère les erreurs dues à -2 et -1 quand on est la 1 ère et 2 ème semaine de l'année !!!
'insère les images qui se trouve dans le même dossier que le classeur, adapter le chemin si différent !
Set Img = Fe.Shapes.AddPicture(ThisWorkbook.Path & "\" & Tbl(2, I) & ".jpg", msoFalse, msoCTrue, 1, 1, 1, 1)
'positionne et dimensionne
With Img
.Name = NomImg
.Left = Range(Tbl(1, I)).Left
.Top = Range(Tbl(1, I)).Top
.Height = Range(Tbl(1, I)).Height
.Width = Range(Tbl(1, I)).Width
End With
Next I
End Sub |
Partager