Formule ou vba pour insérer une image

Version imprimable

31/12/2018, 10h16
persjussysylvain

1 pièce(s) jointe(s)

Formule ou vba pour insérer une image

Bonjour,

Voici mon fichier excel

Je voudrais afficher une image dans la cellule a5:g5 puis h5:n5 puis o5:u5

Les images sont dans le répertoire image et porte le nom du numéro de la semaine

Par exemple dans la cellule a5:g5, le fichier se nomme semaine1.jpg comme indiqué dans la cellulle a1
je voudrais donc une formule qui recherche et insère automatiquement l'image du repertoire image qui correspond au numéro de semaine et qu'elle soit mis à jour si l'image est modifiée
SOIT pour la cellule a5:g5 l'image semaine1.jpg (

Code:

="Mesimages/" & A1&".jpg"

)
pour la cellule h5:n5 l'image semaine2.jpg (

Code:

="Mesimages/" & H1&".jpg"

)
pour la cellule o5:u5 l'image semaine3.jpg (

Code:

="Mesimages/" & O1&".jpg"

)
ETC.

Pouvez-vous m'aider svp ?

Merci beaucoup

Cordialement

Bonjour persjussysylvain,

Le code est ci-dessous - Attention, tes images doivent se nommer SEM1 (pas d'espace entre SEM et le n° de semaine) - Tu peux modifier au cas où.

Code:

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
Option Explicit
 
Sub Transfert_Image()
 
Dim i As Integer
Dim Emplacement As Range
Dim NomImage As String
 
    With Worksheets("Feuil1")
        For i = 1 To 8 Step 7  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, i), Cells(5, i + 6))
            .Pictures.Insert("CHEMIN DE TON DOSSIER\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
            With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        Next i
    End With
 
End Sub

Curt

1 pièce(s) jointe(s)

Bonjour Curt

Merci pour ce code.
Mais je ne comprends pas tout
J'ai noté ce code dans vba de la Feuill1
Mais comment faire pour appeler cette procédure ?
Dois-je mettre quelque chose dans A5, H5 etc. ?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub Transfert_Image() Dim i As Integer Dim Emplacement As Range Dim NomImage As String With Worksheets("Feuil1") For i = 1 To 8 Step 7 'de la colonne 1 (Sem 1) à la 364 (Sem 52) 'INSERTION DE l'IMAGE NomImage = "SEM" & i Set Emplacement = Range(Cells(5, i), Cells(5, i + 6)) .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images With .Shapes(NomImage) .Left = Emplacement.Left .Top = Emplacement.Top .LockAspectRatio = msoFalse .Height = Emplacement.Height .Width = Emplacement.Width End With Next i End With End Sub
Quand je clique sur "lecture" dans le code vba, j'ai ce message : "impossible de lire la propriété Insert dans Pictures" PUIS "erreur définie par l'application ou par l'objet"
mais il m'a bien placé la première image et quand je reclique sur play il m'inscrit le second message et mets l'image mais la même image (SEM1), ne la redimensionne pas donc déborde des cellules concernées et les autres images ne s'affichent pas
=> exemple sur le fichier joint

Et si je veux que l'image se mette non pas dans a5 à g5
mais dans a5 à g9 ?

Je vous remercie

Cordialement

03/01/2019, 21h27
curt

Salut,

le code est à mettre dans le VBE.
Pour y accéder, Alt+F11 puis Double-clic sur Feuil1 et coller le code.
Pour lancer la macro, ALT+F8

Ajoute en début de procédure ON ERROR RESUME NEXT (ça évitera l'erreur si la photo n'existe pas)
De plus, n'oublie pas de boucle jusqu'à 364 (et non 8 qui est pris uniquement pour le test)

Pour ce qui est d'étendre la plage d'affichage, change le 5 (en rouge) par 9

Code:

Set Emplacement = Range(Cells(5, i), Cells(5, i + 6))

Curt

Ok

comme cela dans Feuil1 ?

Code:

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
Option Explicit
 
Sub Transfert_Image()
On Error Resume Next
Dim i As Integer
Dim Emplacement As Range
Dim NomImage As String
 
    With Worksheets("Feuil1")
        For i = 1 To 364 Step 7  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, i), Cells(9, i + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
            With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        Next i
    End With
 
End Sub

Il ne m'affiche que la 1ère image ?
et me dit "excel a cessé de fonctionner" et "excel redémarre" et quand je l'ouvre à nouveau im remet la même image suite à la première sans la redimensionner

Quelqu'un peut m'aider svp ?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub Transfert_Image() Dim i As Integer Dim Emplacement As Range Dim NomImage As String With Worksheets("Feuil1") For i = 1 To 364 Step 7 'de la colonne 1 (Sem 1) à la 364 (Sem 52) 'INSERTION DE l'IMAGE NomImage = "SEM" & i Set Emplacement = Range(Cells(5, i), Cells(9, i + 6)) .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images With .Shapes(NomImage) .Left = Emplacement.Left .Top = Emplacement.Top .LockAspectRatio = msoFalse .Height = Emplacement.Height .Width = Emplacement.Width End With Next i End With End Sub
Quand j'ouvre le fichier, je dois executer la macro (pourquoi ne se fait-elle pas automatiquement) et me note "impossible de lire la propriété insert de la classe pictures"
et m'insere pas les images
si je recommence l'opération il note "erreur d'éxécution 1004 : erreur définie par l'application ou l'objet"

Quand j'enregistre, il m'insère parfois 2 image (SEM1.jpg et SEM8.jpg)
Avec ce code il passe de l'image SEM1.jpg à SEM8.jpg et de 7 en 7
Je voudrais qu'il passe de SEM1 à SEM2 à SEM3 etc.
mais dans les espaces prévus dans le code qui fonctionne
soit pour l'image SEM1 dans A5 à G9
pour la SEM2 dans H5 à N9

J'ai noté mes numéros de semaines dans la ligne 1 :
1 dans A1 - 2 dans H1 - 3 dans O1 - 4 dans V1 etc.

Il est noté "erreur d'application de l'objet", j'ai créé que les 15 premières images sur les 52, c'est peut-être pour ca ?

Merci beaucoup

re

Code:

.Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images

Citation:

Il est noté "erreur d'application de l'objet", j'ai créé que les 15 premières images sur les 52, c'est peut-être pour ca ?

je dirais que les vapeurs alcoolisées du reveillon du 31 ne se sont pas dicipés pour tout le monde ;)

Citation:

c'est peut-être pour ca ?

tu crois????;)

j'en remet une couche

a tu controlé ce que donne I dans ta boucle???????
test ca et regarde dans ton debug tu comprendra tout seul
Code:

1 2 3 4 5 Sub test() For i = 1 To 364 Step 7 'de la colonne 1 (Sem 1) à la 364 (Sem 52) Debug.Print i Next End Sub
si tes 52 images existent et que le chemin est bon teste ca plutot
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Sub Transfert_Image() Dim i&, a&, Emplacement As Range, NomImage As String a = 1 With Worksheets("Feuil1") For i = 1 To 52 'de la colonne 1 (Sem 1) à la 364 (Sem 52) 'INSERTION DE l'IMAGE NomImage = "SEM" & i Set Emplacement = Range(Cells(5, a), Cells(9, a + 6)) .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images With .Shapes(NomImage) .Left = Emplacement.Left .Top = Emplacement.Top .LockAspectRatio = msoFalse .Height = Emplacement.Height .Width = Emplacement.Width End With a = a + 7 Next i End With End Sub
comprends tu que l'iteration de i meme de 1 a 52 ne peux correspondre au colonne de cellules d'emplacement j'ai donc itéré une 2d variable "a" qui elle est itérée de 7 a l'inverse de i qui est de 1
;)

Super
Tout fonctionne

Comment dois-je faire svp pour que la procédure se lance à l'ouverture du fichier ?
J'ai créé une variable fin pour définir la fin d'affichage des images
et remplacer i par num_semaine pour commencer par la semaine actuelle.

Je voudrais lancer l'affichage à l'ouverture du document, j'a donc mis Transfert_Image dans Workbook_open mais ca ne fonctionne pas ?

Comment faire pour écraser les images (ou toutes les effacer) au début du lancement de la procédure svp ?
sinon elles sont toutes superposés au dessous de la première image insérée

Code:

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
Private Sub Workbook_Open()
Transfert_Image
End Sub
 
 
 
Sub Tranfert_Image()
Dim i&, a&, Emplacement As Range, NomImage As String
 a = 1
    With Worksheets("Feuil1")
        Dim prem_date As Single
        Dim nb_date_annee As Date
        Dim num_semaine As Integer
        Dim Fin As Integer
        nb_date_annee = DateValue("1 janvier " & (Year(Date)))
        prem_date = nb_date_annee
        num_semaine = Abs(Date - prem_date) / 7
        Range("c15").Value = "S" & " " & num_semaine
 
        If num_semaine < 46 Then Fin = num_semaine + 5 Else Fin = 52
 
        For i = num_semaine To Fin  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, a + 7 * (num_semaine - 1)), Cells(9, a + 7 * (num_semaine - 1) + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
             With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        a = a + 7
        Next i
    End With
End Sub

Je vous remercie beaucoup

Cordialement

Bonsoir,
J'ai voulu insérer ce code mais je n'arrive pas à appeler la procédure ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub SupprimerLesImages_Feuille_Active()
'par: Excel-Malin.com ( https://excel-malin.com )
Application.ScreenUpdating = False
 
On Error GoTo SupprimerLesImagesErreur
 
Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img
 
Exit Sub
SupprimerLesImagesErreur:
    MsgBox "Une erreur est survenue..."
Application.ScreenUpdating = True
End Sub

Donc J'ai insérer une partie de ce code pour effacer les images en début de procédure
mais je n'arrive toujours pas à appeler la procédure depuis WorkBook_Open ?

Code:

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
Option Explicit
Private Sub Workbook_Open()
Call Transfert_Image
End Sub
 
 
Sub Tranfert_Image()
 
Dim i&, a&, Emplacement As Range, NomImage As String
'par: Excel-Malin.com ( https://excel-malin.com )
Application.ScreenUpdating = False
 
Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img
 a = 1
    With Worksheets("Feuil1")
        Dim prem_date As Single
        Dim nb_date_annee As Date
        Dim num_semaine As Integer
        Dim Fin As Integer
        nb_date_annee = DateValue("1 janvier " & (Year(Date)))
        prem_date = nb_date_annee
        num_semaine = Abs(Date - prem_date) / 7
        Range("c15").Value = "S" & " " & num_semaine
 
        If num_semaine < 46 Then Fin = num_semaine + 2 Else Fin = 52
 
        For i = num_semaine To Fin  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, a + 7 * (num_semaine - 1)), Cells(9, a + 7 * (num_semaine - 1) + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
             With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        a = a + 7
        Next i
    End With
End Sub

re
dans le module thisworkbook

Code:

1
2
3
4
Option Explicit
Private Sub Workbook_Open()
Call Transfert_Image
End Sub

dans un module standard
je verifie pas les modif que tu a fait je te fait confiance

Code:

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
Sub Tranfert_Image()
 
Dim i&, a&, Emplacement As Range, NomImage As String
'par: Excel-Malin.com ( https://excel-malin.com )
Application.ScreenUpdating = False
 
Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img
 a = 1
    With Worksheets("Feuil1")
        Dim prem_date As Single
        Dim nb_date_annee As Date
        Dim num_semaine As Integer
        Dim Fin As Integer
       Dim Img As Object
For Each Img In ActiveSheet.Pictures
    Img.Delete
Next Img nb_date_annee = DateValue("1 janvier " & (Year(Date)))
        prem_date = nb_date_annee
        num_semaine = Abs(Date - prem_date) / 7
        Range("c15").Value = "S" & " " & num_semaine
 
        If num_semaine < 46 Then Fin = num_semaine + 2 Else Fin = 52
 
        For i = num_semaine To Fin  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, a + 7 * (num_semaine - 1)), Cells(9, a + 7 * (num_semaine - 1) + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
             With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        a = a + 7
        Next i
    End With
End Sub

peut etre un test dir sur le chemin avant le pictures.insert serait un plus

J'ai "sub ou fonction non définie"

J'ai dans Workbook - Open de This Workbook

Code:

1
2
3
4
Option Explicit
Private Sub Workbook_Open()
Call Transfert_Image
End Sub

et dans General - Transfert image de Feuill1

Code:

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
Option Explicit
Sub Transfert_Image()
 Dim xPicRg As Range
    Dim xPic As Shape
    Dim xRg As Range
 
    Application.ScreenUpdating = False
 
    Set xRg = Range("A5:MZ9")
 
        For Each xPic In ActiveSheet.Shapes
 
            Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
            If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
 
        Next
 
    Application.ScreenUpdating = True
 
Dim i&, a&, Emplacement As Range, NomImage As String
'par: Excel-Malin.com ( https://excel-malin.com )
Application.ScreenUpdating = False
 a = 1
    With Worksheets("Feuil1")
        Dim prem_date As Single
        Dim nb_date_annee As Date
        Dim num_semaine As Integer
        Dim Fin As Integer
        nb_date_annee = DateValue("1 janvier " & (Year(Date)))
        prem_date = nb_date_annee
        num_semaine = Abs(Date - prem_date) / 7
        Range("c15").Value = "S" & " " & num_semaine
 
        If num_semaine < 46 Then Fin = num_semaine + 2 Else Fin = 52
 
        For i = num_semaine To Fin  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(5, a + 7 * (num_semaine - 1)), Cells(9, a + 7 * (num_semaine - 1) + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
             With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        a = a + 7
        Next i
    End With
End Sub

Ou est mon erreur svp ?

Merci

Bonjour,

J'ai mis à jour ce code pour le mettre dans mon fichier officiel

J'ai donc changé les cellules
mail il m'affiche l'image (semaine 2 : du 7 au 13 janvier) à partir de la colonne H et non D ou K => alors que nous sommes en semaine 3
D est la colonne du début du code

Code:

Set xRg = Range("d63:NE67")

K est le lundi de la semaine 2 soit le lundi 7 janvier

Ou est mon erreur svp ?
je voudrais afficher uniquement les 2 semaines précédentes la semaine actuelle, la semaine actuelle et les 3 semaines suivantes

Code:

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
Option Explicit
 
Sub Transfert_Image()
    Dim xPicRg As Range
    Dim xPic As Shape
    Dim xRg As Range
 
    Application.ScreenUpdating = False
 
    Set xRg = Range("d63:NE67")
 
        For Each xPic In ActiveSheet.Shapes
 
            Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
            If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
 
        Next
 
    Application.ScreenUpdating = True
 
Dim i&, a&, Emplacement As Range, NomImage As String
'par: Excel-Malin.com ( https://excel-malin.com )
Application.ScreenUpdating = False
 a = 1
    With Worksheets("Plannings pour educs")
        Dim prem_date As Single
        Dim nb_date_annee As Date
        Dim num_semaine As Integer
        Dim Fin As Integer
        nb_date_annee = DateValue("1 janvier " & (Year(Date)))
        prem_date = nb_date_annee
        num_semaine = Abs(Date - prem_date) / 7
        Range("d75").Value = "S" & " " & num_semaine
 
        If num_semaine < 46 Then Fin = num_semaine + 2 Else Fin = 52
 
        For i = num_semaine To Fin  'de la colonne 1 (Sem 1) à la 364 (Sem 52)
            'INSERTION DE l'IMAGE
            NomImage = "SEM" & i
            Set Emplacement = Range(Cells(63, a + 7 * (num_semaine - 1)), Cells(67, a + 7 * (num_semaine - 1) + 6))
            .Pictures.Insert("Q:\Commun\5. Plannings\Image outllok\SEM" & i & ".jpg").Name = NomImage 'C'est ici que tu dois mettre le chemin du dossier de tes images
             With .Shapes(NomImage)
                .Left = Emplacement.Left
                .Top = Emplacement.Top
                .LockAspectRatio = msoFalse
                .Height = Emplacement.Height
                .Width = Emplacement.Width
            End With
        a = a + 7
        Next i
    End With
End Sub

Je vous remercie de votre aide

Cordialement

15/01/2019, 18h20
persjussysylvain

Bonsoir

J'ai corrigé cette ligne en remplacant 7 par 10 et ca fonctionne

Code:

Set Emplacement = Range(Cells(63, a + 10 * (num_semaine - 1)), Cells(67, a + 10 * (num_semaine - 1) + 6))

mais cela ne me semble pas bien logique, je ne comprends pas

Vous avez une idée svp ?

Comment faire pour afficher également la semaine précédente ou les 2 semaines précédentes ?

Merci

Bonjour,

Le code présenté ici est conçu pour le fichier donné en exemple à savoir que les noms des semaines se trouvent en ligne 1, et les zones d'incrustation des images 4 lignes plus bas. Le chemin des images est le même que celui du classeur donc, dans le même dossier, si le dossier est différent, adapter dans la ligne indiqué par le commentaire, de toutes façons, lire les commentaires pour comprendre le fonctionnement et adapter aux besoins :

Code:

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
 
Sub Test()
 
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim CelPos As Range
    Dim Img As Shape
    Dim NumSem As Integer
    Dim NomImg As String
 
    'adapter le nom de la feuille
    Set Fe = Worksheets("Feuil1")
 
    'défini le numéro de la semaine
    NumSem = Format(Date, "WW")
 
    'concatène
    NomImg = "semaine" & NumSem
 
    'si l'image a déjà été entrée, fin !
    For Each Img In Fe.Shapes
 
        If Img.Name = NomImg Then Exit Sub
 
    Next Img
 
 
    'défini la plage des noms de semaines sur la ligne 1
    With ActiveSheet: Set Plage = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)): End With
 
    'effectue une recherche exacte du nom de la semaine
    Set Cel = Plage.Find(NomImg, , xlValues, xlWhole)
 
    'si pas trouvé (orthographe, espaces parasites, etc...) fin !
    If Cel Is Nothing Then Exit Sub
 
    'défini la cellule devant recevoir l'image
    Set CelPos = Cel.Offset(4)
 
    'insère l'image qui se trouve dans le même dossier que le classeur, adapter le chemin si différent !
    Set Img = Fe.Shapes.AddPicture(ThisWorkbook.Path & "\" & NomImg & ".jpg", msoFalse, msoCTrue, 1, 1, 1, 1)
 
    'positionne et dimensionne
    With Img
 
        .Name = NomImg
        .Left = CelPos.MergeArea.Left
        .Top = CelPos.MergeArea.Top
        .Height = CelPos.MergeArea.Height
        .Width = CelPos.MergeArea.Width
 
    End With
 
End Sub

16/01/2019, 16h07
persjussysylvain

Ce code fonctionne
Mais l'image ne se redimensionne pas

Et dans la ligne 1, j'ai les dates
Par exemple : A1(L 14/1) - A2(Ma 15/1) - A3(Me15-1)
Donc je voudrais que la semaine soit calculée selon la date de A1 puis H1 etc.
et que l'image apparaissent par exemple pour la semaine 3 de la cellule A5 à G5
et je voudrais que soit affichées les images de la semaine -2 à la semaine +2

Est-ce possible svp?
16/01/2019, 16h42
Theze

Bon et bien soit tu postes le classeur original anonymisé soit j'en reste là car sinon, on va se courir après parce que dans le classeur que tu as posté il y a "semaine1" en A1 et non "L 14/1" !
16/01/2019, 16h58
persjussysylvain

1 pièce(s) jointe(s)

Voici mon fichier exemple

Désolé

1 pièce(s) jointe(s)

Le code par rapport au dernier classeur posté (le classeur est en retour) :

Code:

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
 
Sub Test()
 
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim Zone As Range
    Dim Img As Shape
    Dim NumSem As Integer
    Dim NomImg As String
    Dim Trouve As Boolean
 
    '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 ActiveSheet: Set Plage = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)): End With
 
    '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 la zone devant recevoir l'image (7 jours)
            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)
 
    'concatène
    NomImg = "semaine" & NumSem
 
    'si l'image a déjà été entrée, fin !
    For Each Img In Fe.Shapes
 
        If Img.Name = NomImg Then Exit Sub
 
    Next Img
 
    'insère l'image qui se trouve dans le même dossier que le classeur, adapter le chemin si différent !
    Set Img = Fe.Shapes.AddPicture(ThisWorkbook.Path & "\" & NomImg & ".jpg", msoFalse, msoCTrue, 1, 1, 1, 1)
 
    'positionne et dimensionne
    With Img
 
        .Name = NomImg
        .Left = Zone.Left
        .Top = Zone.Top
        .Height = Zone.Height
        .Width = Zone.Width
 
    End With
 
End Sub

Le classeur :
Pièce jointe 442067

17/01/2019, 18h22
persjussysylvain

1 pièce(s) jointe(s)

L'image de la semaine actuelle (semaine3) apparait mais sans être redimensionné

Serait-il possible d'afficher les images de la semaine -2 à la semaine + 5 ?

Je vous remercie

Bonjour,

Voici le code pour les 8 images :

Code:

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

Citation:

L'image de la semaine actuelle (semaine3) apparait mais sans être redimensionné

Chez moi avec Excel 2007, tout fonctionne parfaitement, le code précédent et celui-ci et il n'y a aucune raison que ça ne fonctionne pas ou alors tu testes sur un fichier qui est encore différent de celui posté donc, je ne peux pas t'aider sur ce coup là, à toi de trouver pourquoi en faisant du pas à pas (touche F8) et en contrôlant les valeurs au survol de la souris ou ave debug.print

2 pièce(s) jointe(s)

Bonjour,

J'ai toujours le même problème de redimensionnement des images

Pièce jointe 442536

J'ai rajouté

Code:

.LockAspectRatio = msoFalse

dans la partie
Code:

1 2 3 4 5 6 7 8 9 10 With Img .Name = NomImg .Left = Range(Tbl(1, I)).Left .Top = Range(Tbl(1, I)).Top .LockAspectRatio = msoFalse .Height = Range(Tbl(1, I)).Height .Width = Range(Tbl(1, I)).Width End With
au cas ou mais ca ne change rien

Je ne comprends pas, sinon cela semble bien fonctionner mais je n'arrive pas à voir si les images correspondent aux bonnes semaines comme je ne les reconnais pas

????

Cordialement

18/01/2019, 12h25
Theze

1 pièce(s) jointe(s)

Comme je te l'ai dis, chez moi ça fonctionne très bien et d'ailleurs, voici une capture d'écran :

Pièce jointe 442548
18/01/2019, 13h01
persjussysylvain

ok.

Je vais essayer de comprendre le problème sur mon fichier
Pourquoi la 4ème image s'affiche alors qu'il n'y aplus de date sur la ligne
Ta première image correspond à la semaine du 7 au 13/01
Donc a quoi correspond la 4eme image?
Merci

Bonjour,

Citation:

Pourquoi la 4ème image s'affiche alors qu'il n'y a plus de date sur la ligne

Tout simplement parce que, à partir du moment où la comparaison est vrai à cette ligne de code :
Code:

1 2 If Format(Cel.Value, "WW", vbMonday) = Format(Date, "WW", vbMonday) Then
Le code ne cherche plus les dates mais récupère les plages de -2 semaines à +5 semaines :
Code:

1 2 3 4 5 6 7 8 9 10 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
où le point de référence est :
Code:

1 2 Tbl(1, 3) = Range(Cel.Offset(4), Cel.Offset(4, 6)).Address
et ce point de référence est la semaine en cours !

Citation:

Ta première image correspond à la semaine du 7 au 13/01
Donc a quoi correspond la 4eme image?

ce n'est pas la première image puisque tu vois bien que la lettre de colonne n'est pas A mais H (j'ai joué avec l'ascenseur horizontal) et donc, correspond à la semaine numéro 2, du 07/01/19 au 13/01/19 donc semaine en cours - 1