Affichage image après recherche verticale

Bonjour tout le monde,

J'aimerais savoir si l'un d'entre vous aurait une solution à mon petit problème. J'ai une macro qui génère des questionnaires. Je vous le mets en pièce jointe. Mais certaines questions requièrent une image. Les liens des images correspondants aux questions sont insérés dans la colonne à droite de la question.

J'aimerais qu'à chaque création de questionnaires, la macro, pour chaque question générée, aille rechercher la même dans la base de questionnaire et vérifie si à droite apparait un lien image. Si oui, alors elle m'insère l'image, si rien, elle passe à la suivante.

J'ai pensé à faire une recherche verticale mais je galère énormément.

Si vous avez besoin de plus d'infos, je suis dispo.

Merci aux courageux^^

Bonjour,

Si dans la feuille "Base de questionnaire" > en colonne D > les chemins sont bons en sous-dossier, tels que présentement, de "ThisWorkBook.Path" (où est situés le fichier "Générateur de questionnaires") > (pas besoin qu'ils soient des hyperliens) ...

Ceci devrait fonctionner ...

Sub test()
Dim nbQuestion As Byte
Dim nbQuestionObligatoire As Byte
Dim nbQuestionNonObligatoireTotal As Byte
Dim nbQuestionAlea As Byte
Dim nomFeuille As String
Dim numQuestion As Byte
Dim nbParticipants As Byte
Dim x, y As Byte
Dim plage As Range, cel As Range, alea As Double
Dim Image As Variant
Dim L As Single, T As Single, W As Single, H As Single

    'On désactive les messages d'alertes d'excel et on désactive le défilement des macros
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    nbParticipants = Worksheets("Base de questionnaire").Range("B1").Value

    For y = 1 To nbParticipants

    'Sheets.Add After:=Worksheets(Sheets.Count)
        Worksheets("Template").Copy After:=Worksheets(Sheets.Count)
        Worksheets(Sheets.Count).Name = "Questionnaire " & (Sheets.Count - 3)
        nomFeuille = "Questionnaire " & (Sheets.Count - 3)

        Worksheets("Base de questionnaire").Range("A4:D200").Sort key1:=Worksheets("Base de questionnaire").Range("A4"), order1:=xlAscending, key2:=Worksheets("Base de questionnaire").Range("D4"), order2:=xlAscending, Orientation:=xlTopToBottom
        nbQuestionObligatoire = 0

        For Each Cell In Worksheets("Base de questionnaire").Range("A4:A" & Worksheets("Base de questionnaire").Range("A50").End(xlUp).Row)
            If Cell = "Oui" Then nbQuestionObligatoire = nbQuestionObligatoire + 1
        Next Cell

        nbQuestion = Worksheets("Base de questionnaire").Range("B2").Value - nbQuestionObligatoire
        nbQuestionNonObligatoireTotal = Worksheets("Base de questionnaire").Range("C65000").End(xlUp).Row - 3 - nbQuestionObligatoire

        For x = 1 To nbQuestionObligatoire
            Worksheets("Base de questionnaire").Range("C" & (x + 3)).Copy
            Worksheets(nomFeuille).Range("A" & x).PasteSpecial
            Rows("1:1").EntireRow.autofit

            '' ######1 <<<<<<<<<<<<<<<<<<<<<<<<<<< Insertion Image
            If Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value <> "" Then
                Image = ThisWorkbook.Path & "\" & Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value
                    Worksheets(nomFeuille).Range("B" & x).Select
                    Worksheets(nomFeuille).Range("B" & x).RowHeight = 195
                    L = Range("B" & x).Left
                    T = Range("B" & x).Top
                    W = Range("B" & x).Width
                    H = Range("B" & x).Height
                    Worksheets(nomFeuille).Shapes.AddPicture Image, True, True, L, T, W, H
            End If
            '' ###### <<<<<<<<<<<<<<<<<<<<<<<<<<< fin insertion image 
        Next x

        Set plage = Worksheets("Base de questionnaire").Range("AB1:AB" & nbQuestion)
        plage.Value = ""

        If plage.Count > nbQuestionNonObligatoireTotal Then Exit Sub
        Randomize

        For Each cel In plage
1           alea = WorksheetFunction.RandBetween(1, nbQuestionNonObligatoireTotal)
            If Application.CountIf(plage, alea) Then GoTo 1 Else cel = alea
        Next

        For x = 1 To nbQuestion
            numQuestion = Worksheets("Base de questionnaire").Range("AB" & x).Value
            Worksheets(nomFeuille).Range("A" & (Worksheets(nomFeuille).Range("A65000").End(xlUp).Row + 1)).Value = Worksheets("Base de questionnaire").Range("C" & numQuestion + 3 + nbQuestionObligatoire).Value
        Next x

    'On enlève les bordures
        Range("A1:A50").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        plage.Clear
    Next y

    'On réactive les messages d'alertes d'excel et on réactive le défilement des macros
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

End Sub

ric

Merci beaucoup de ta réponse.

Cependant, la macro ne m'insère aucune image. J'ai essayé en utilisant un hyperlien ainsi que juste le chemin d'accès et rien ne se passe. Et aucun défaut sur le code car aucun débogage. Je ne comprends pas.^^

Saurais-tu ce que pourrait être ce défaut ?

Sinon, si tu peux juste m'expliquer tes quelques lignes de code, ce serait bien pour que je puisse tenter des modifications afin de faire en sorte que ça fonctionne, comme tu veux

Merci beaucoup.

Damien

Bonjour,

Je ne connais pas les restrictions de la version Starter d'Excel 2010.

Mais, le fichier a été testé et il fonctionne bien (macro et hyperliens).

Si même les liens hypertextes ne fonctionnent pas après avoir vérifié que les fichiers images sont bien présents dans le chemin indiqué et dont les noms sont bons ... j'ai tendance à vouloir incriminer Excel Starter ... en espérant ne pas condamner outre mesure cette version très allégée.

ric

Oops, désolé, je n'ai pas mis à jour cette donnée, ma version d'excel est celle du pack office professionnal 2013. Pas la starter 2010. Je vais mettre ça à jour. Donc je suppose qu'il n'y pas forcément de restriction. Après, j'ai juste inséré la partie "insertion image", peut-être aurais-je dû tout prendre.

Bonjour,

Sous Excel 2013 > les liens hypertextes et la macro devraient bien fonctionner.

Si les liens ne fonctionnent pas, ce qui laisse soupçonner que les chemins ou le nom des fichiers posent problème.

Teste cette version jointe ...

ric

HAHA Ca marche!!! Merci beaucoup!!

Me reste plus qu'à faire en sorte que l'image se mette en dessous de la question et c'est bon!!

Juste, as-tu une idée de pourquoi ça marche lorsque l'image est sur l'ordinateur, et non quand l'image se trouve sur le réseau de l'entreprise ?

Worksheets(nomFeuille).Shapes.AddPicture Image, True, True, L, T, W, H

Celle-ci se met en défaut lorsque le lien renvoi vers le réseau et non directement sur l'ordinateur.

Encore merci, vraiment!!

Bonjour,

            '' ######1 <<<<<<<<<<<<<<<<<<<<<<<<<<< Insertion Image
            If Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value <> "" Then
                Image = ThisWorkbook.Path & "\" & Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value
                If Image <> False Then
                    Worksheets(nomFeuille).Range("B" & x).Select
                    Worksheets(nomFeuille).Range("B" & x).RowHeight = 195
                    L = Range("B" & x).Left
                    T = Range("B" & x).Top
                    W = Range("B" & x).Width
                    H = Range("B" & x).Height
                    Worksheets(nomFeuille).Shapes.AddPicture Image, True, True, L, T, W, H
                End If
            End If
            '' ######1 <<<<<<<<<<<<<<<<<<<<<<<<<<<

Dans cette partie ... j'ai fait référence à "le chemin de ce classeur" (ThisWorkbook.path) ...

Cette instruction sera à changer pour faire référence au nouveau chemin sur le réseau de l'entreprise.

Le chemin du réseau de l'entreprise & "\" & Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value

Le chemin du réseau de l'entreprise peut être le chemin même ou une variable qui contient ce chemin.

ric

"Le chemin du réseau de l'entreprise peut être le chemin même ou une variable qui contient ce chemin"

Cette phrase vient de me faire tourner de l'oeil

Je crois que je mettrai toutes les images directement sur l'ordinateur

Bonjour,

Ce n'est pourtant pas difficile ...

Dim LeChemin as String

Lechemin = "\\leNomDuServeur\leNomDuDossier\leNomduSousDossier\" 

Image = LeChemin & Worksheets("Base de questionnaire").Range("D" & (x + 3)).Value
                If Image <> False Then

Il ne reste qu'à adapter le chemin ...

Puis, en sous-sous-dossier, le reste du chemin est dans la cellule Training Center LDG\Module 1 Bandclamps\ et enfin l'image.

ric