IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Formule ou vba pour insérer une image


Sujet :

Macros et VBA Excel

  1. #1
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut 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 : Sélectionner tout - Visualiser dans une fenêtre à part
    ="Mesimages/" & A1&".jpg"
    )
    pour la cellule h5:n5 l'image semaine2.jpg (
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    ="Mesimages/" & H1&".jpg"
    )
    pour la cellule o5:u5 l'image semaine3.jpg (
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    ="Mesimages/" & O1&".jpg"
    )
    ETC.

    Pouvez-vous m'aider svp ?

    Merci beaucoup

    Cordialement
    Fichiers attachés Fichiers attachés

  2. #2
    Membre émérite Avatar de curt
    Homme Profil pro
    Ingénieur Etudes
    Inscrit en
    Mars 2006
    Messages
    1 564
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur Etudes
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : Mars 2006
    Messages : 1 564
    Points : 2 523
    Points
    2 523
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    Pas de demande par MP, sinon j'correctionne plus, j'dynamite, j'disperse, j'ventile !!!
    ---------------------------------------------------------------------
    Vous avez un talent insoupçonné... Faites-en profitez les autres. Un p'tit CLIC pour une grande cause.
    Et si vous faisiez un bon geste en 2024 ? Soyez utile, ça vous changera ! Moi, ça m’a changé !

  3. #3
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    Fichiers attachés Fichiers attachés

  4. #4
    Membre émérite Avatar de curt
    Homme Profil pro
    Ingénieur Etudes
    Inscrit en
    Mars 2006
    Messages
    1 564
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur Etudes
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : Mars 2006
    Messages : 1 564
    Points : 2 523
    Points
    2 523
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    Set Emplacement = Range(Cells(5, i), Cells(5, i + 6))
    Curt
    Pas de demande par MP, sinon j'correctionne plus, j'dynamite, j'disperse, j'ventile !!!
    ---------------------------------------------------------------------
    Vous avez un talent insoupçonné... Faites-en profitez les autres. Un p'tit CLIC pour une grande cause.
    Et si vous faisiez un bon geste en 2024 ? Soyez utile, ça vous changera ! Moi, ça m’a changé !

  5. #5
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    Ok

    comme cela dans Feuil1 ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  6. #6
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    Quelqu'un peut m'aider svp ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  7. #7
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    re
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    .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
    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

    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  8. #8
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  9. #9
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    Bonsoir,
    J'ai voulu insérer ce code mais je n'arrive pas à appeler la procédure ?
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  10. #10
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    re
    dans le module thisworkbook

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  11. #11
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    J'ai "sub ou fonction non définie"

    J'ai dans Workbook - Open de This Workbook
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    Option Explicit
    Private Sub Workbook_Open()
    Call Transfert_Image
    End Sub
    et dans General - Transfert image de Feuill1

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  12. #12
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
     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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  13. #13
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    Bonsoir

    J'ai corrigé cette ligne en remplacant 7 par 10 et ca fonctionne
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  14. #14
    Expert éminent
    Homme Profil pro
    Inscrit en
    Août 2010
    Messages
    3 453
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Août 2010
    Messages : 3 453
    Points : 6 871
    Points
    6 871
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  15. #15
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    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. #16
    Expert éminent
    Homme Profil pro
    Inscrit en
    Août 2010
    Messages
    3 453
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Août 2010
    Messages : 3 453
    Points : 6 871
    Points
    6 871
    Par défaut
    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" !

  17. #17
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    Voici mon fichier exemple


    Désolé
    Fichiers attachés Fichiers attachés

  18. #18
    Expert éminent
    Homme Profil pro
    Inscrit en
    Août 2010
    Messages
    3 453
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Août 2010
    Messages : 3 453
    Points : 6 871
    Points
    6 871
    Par défaut
    Le code par rapport au dernier classeur posté (le classeur est en retour) :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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 :
    Classeur4b version 2.xlsm

  19. #19
    Membre du Club
    Homme Profil pro
    Accompagnateur personnes handicapés
    Inscrit en
    Juillet 2016
    Messages
    111
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Accompagnateur personnes handicapés

    Informations forums :
    Inscription : Juillet 2016
    Messages : 111
    Points : 47
    Points
    47
    Par défaut
    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
    Fichiers attachés Fichiers attachés

  20. #20
    Expert éminent
    Homme Profil pro
    Inscrit en
    Août 2010
    Messages
    3 453
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Août 2010
    Messages : 3 453
    Points : 6 871
    Points
    6 871
    Par défaut
    Bonjour,

    Voici le code pour les 8 images :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    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

+ Répondre à la discussion
Cette discussion est résolue.
Page 1 sur 2 12 DernièreDernière

Discussions similaires

  1. Problème pour insérer une image
    Par merwandonut dans le forum Tableaux - Graphiques - Images - Flottants
    Réponses: 3
    Dernier message: 20/04/2008, 21h01
  2. Réponses: 8
    Dernier message: 11/02/2008, 20h37
  3. [VBA-Excel] Insérer une image à une treeview
    Par marsupilami34 dans le forum Macros et VBA Excel
    Réponses: 4
    Dernier message: 23/08/2006, 16h54
  4. Réponses: 2
    Dernier message: 03/08/2006, 19h21
  5. Problème pour insérer une image
    Par Paulinho dans le forum Tableaux - Graphiques - Images - Flottants
    Réponses: 4
    Dernier message: 27/04/2006, 00h36

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo