XL 2016 Besoin d'aide pour alléger ma macro

A

Anais0998

XLDnaute Nouveau
Bonjour à tous,

J'apprends le VBA "sur le tas" et depuis peu. J'arrive à trouver e adapter les codes dont j'ai besoin, mais ce n'est pas toujours évident.
Actuellement je travaille sur un fichier excel pour générer des sujets d'évaluation pour des centres de formation pour adultes.

Il y a 2 niveaux d'évaluations, 3 et 4, mais une seule base de données où sont regroupées toutes les questions par thème, les réponses, ...

A partir de cette BDD, j'ai une colonne qui me permet, lorsque je clique 2 fois sur les lignes correspondant aux questions, de générer les sujets.

Pour la partie santé et sécurité, certaines questions portent sur des pictogrammes. Je souhaitais pouvoir insérer ces pictos dans le sujet grâce à une méthode événementielle , mais je n'y suis pas arrivée.

A partir de l'enregistreur de macro, j'ai pu mettre en place une macro qui me permet de placer les pictos aux emplacements du sujet correspondants aux questions, que j'active à partir d'un bouton.

Le soucis est que cette macro est très longue, et malgré "application.screenupdating" au début et à la fin de mon code, le déroulement de cette macro est assez longue et disgracieuse.

Pourriez vous m'aider à alléger ce code afin d'avoir un déroulement de macro normal et qui passe inaperçu ?

je vous place ci dessous les captures d'écran de ma feuille "sujet" (SujetNC3) et de ma feuille (ListesEval) où sont stockés mes pictos.
Et je place aussi mon code en plusieurs fois car ça ne passe pas sinon.

Je vous remercie d'avance pour votre aide et je vous souhaite une belle journée.


1034061






1034062

VB: 
Sub Questions_sante_securite()
Application.ScreenUpdating = False

If Range("C99").Value = 1 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 46")).Select
    Selection.Copy
        Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
        ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
    End If
    
    
If Sheets("SujetNC3").Range("C99").Value = 2 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 44")).Select
    Selection.Copy
        Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
   End If
  
        
If Range("C99").Value = 3 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 50")).Select
        Selection.Copy
           Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
        
ElseIf Range("C99").Value = 4 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 17")).Select
        Selection.Copy
           Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4

    
ElseIf Range("C99").Value = 5 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 40")).Select
        Selection.Copy
          Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
            
    
ElseIf Range("C99").Value = 6 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 39")).Select
        Selection.Copy
            Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
      
    
ElseIf Range("C99").Value = 7 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 42")).Select
    Selection.Copy
            Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
        
    
ElseIf Range("C99").Value = 8 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 10")).Select
    Selection.Copy
           Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4
        
    
ElseIf Range("C99").Value = 9 Then
    Sheets("ListesEval").Select
    ActiveSheet.Shapes.Range(Array("Picture 48")).Select
    Selection.Copy
           Sheets("SujetNC3").Select
        Rows("99:99").Select
        Selection.RowHeight = 41
        Range("B99").Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 355.8
            Selection.ShapeRange.IncrementTop 2.4

    End If

If Range("C104").Value = 1 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 46")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Sheets("SujetNC3").Range("C104").Value = 2 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 44")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 3 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 50")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 4 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 17")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 5 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 40")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 6 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 39")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 7 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 42")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 8 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 10")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Range("C104").Value = 9 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 48")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("104:104").Select
Selection.RowHeight = 41
Range("B104").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

End If





If Range("C109").Value = 1 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 46")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4


ElseIf Sheets("SujetNC3").Range("C109").Value = 2 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 44")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 3 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 50")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 4 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 17")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 5 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 40")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 6 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 39")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 7 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 42")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 8 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 10")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C109").Value = 9 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 48")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("109:109").Select
Selection.RowHeight = 41
Range("B109").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4
End If






If Range("C114").Value = 1 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 46")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Sheets("SujetNC3").Range("C114").Value = 2 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 44")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 3 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 50")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 4 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 17")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 5 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 40")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 6 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 39")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 7 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 42")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 8 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 10")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4

ElseIf Range("C114").Value = 9 Then
Sheets("ListesEval").Select
ActiveSheet.Shapes.Range(Array("Picture 48")).Select
Selection.Copy
Sheets("SujetNC3").Select
Rows("114:114").Select
Selection.RowHeight = 41
Range("B114").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 355.8
Selection.ShapeRange.IncrementTop 2.4
End If



Sheets("SujetNC3").Select
Application.ScreenUpdating = True

End Sub
 
Trier par date Trier par votes
A

Anais0998

XLDnaute Nouveau
ChTi160 à dit:
Bonjour Anais
Bonjour le fil , le Forum
pour ce qui est de mon post ＃6
sur que ca ne va pas fonctionner（ne perds pas ton temps lol）
pour ce qui est de ton fichier.
pas besoin de tout , un sujet dans page （SujetNC3）quelques elements de ce sujet dans la feuille （ListesEval）
et des explications de ce que tu veux et comment（tu parles de procedures evenementielle DoubleClick）
jean marie
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
A

Anais0998

XLDnaute Nouveau
Bonjour ChTi160,
J'ai réduit mon fichier pour ne garder que le strict minimum nécessaire, mais ça ne passe toujours pas.

Effectivement, ton code ne donne pas le résultat escompté, et c'est le même constat pour tous les autres codes que l'on m'a proposé.

C'est dommage pour le fichier, il n'est pourtant pas très lourd (1252 ko).
Je t'explique quand même le fonctionnement de mon fichier, au cas où tu aurais d'autres idées :
Après avoir enlevé toutes les feuilles relatives au sujet 4 et d'autres feuilles secondaires, il me reste :
* 1 feuille contenant la base de données des questions. à partir de cette bdd, j'ai une colonne où j'ai programmé une macro (worksheet-beforedoubleclik), ce qui me permet, lorsque je clique dans cette colonne, de renseigner dans une autre colonne le numéro de la question correspondante.
Cette colonne alimente une recherchev placée dans ma feuille SujetNC3, ce qui permet de transférer directement les questions choisies ainsi que les 3 propositions de réponse, dans le sujet.
Je sélectionne ainsi toutes mes questions (4 par thème) + 1 question étiquette, dont la base de données est sur une autre feuille. Ensuite, j'ai placé dans le sujet au niveau des questions "santé et sécurité", un bouton associé à ma très longue macro qui va chercher dans ma feuille ListesEval les pictos pour les placer dans ma feuille SujetNC3 au niveau des questions correspondantes.
Tout fonctionne, le soucis c'est que le déroulement de la macro est vraiment long et ça provoque comme un séisme de magnitude 7 sur ma feuille pendant quelques secondes pour arriver au résultat escompté. BREF, j'ai également :
* 1 feuille sujetNC3 : au niveau des 4 questions "santé et sécurité", il y a des formules qui alimentent les cellules C99 C 104 C 109 et C114.
La formule dit que si la question est la question du picto 1 alors afficher 1, si la question est la question du picto 2 alors afficher 2, ainsi de suite, et pareil pour les 4 questions. Ensuite, la macro tient compte et du numéro de la question et de la cellule qui doit recevoir le picto, etc
d'où la difficulté de procéder par boucles.
*1 feuille ListesEval
*1 feuille QuestionsEtiquette

Au début, j'ai voulu tout regrouper dans ma macro événementielle qui génère les questions, et la macro qui rapatrie les pictos, mais là c'était séisme de magnitude +++, donc j'ai séparé les macro et j'ai placé un bouton pour lancer le transfert des pictos.

Voili voilà j'espère que tu vas comprendre mon chmilblik ... Et m'orienter vers d'autres solutions.
Je te remercie d'avance pour ton aide, de mon côté je continue de tester encore et encore
 

Pièces jointes

  • Capturemmm.JPG
    Capturemmm.JPG
    34.8 KB · Affichages: 16
Vote positif 0 Vote négatif
J

JM27

XLDnaute Barbatruc
bonjour
les fichiers sont limité à 1 MO

et en zippant ton fichier ?

essayes

Application.Calculation = xlManual

en début de macro
'
Application.Calculation = xlAutomatic
et en fin de macro
 
Dernière édition:
Vote positif 0 Vote négatif
J

JM27

XLDnaute Barbatruc
Bonjour
et comme cela ?
dans le module de la feuille SujetNC3
Si cela fonctionne on pourra optimiser le code en supprimant si possible les select
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligneDeTraitement As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    If Not Intersect([A99,A104,A109,A114], Target) Is Nothing And Target.Count = 1 Then
       If Target > 0 And Target < 10 Then
        Application.EnableEvents = False
        ligneDeTraitement = Target
        Sheets("ListesEval").Select
        ActiveSheet.Shapes.Range(Array("Picture " & ligneDeTraitement)).Select
        Selection.Copy
        Sheets("SujetNC3").Select
        Target.Rows.Select
        Selection.RowHeight = 41
        Range("B" & Target.Row).Select
        ActiveSheet.Paste
        Selection.ShapeRange.IncrementLeft 355.8
        Selection.ShapeRange.IncrementTop 2.4
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
       End If
    End If
End Sub

et pour éviter de surcharger ta feuille SujetNC3 d'images qui se super-positionneront les unes sur les autres
mettre un bouton pour effacer toutes les shapes
Code: 
Sub Macro1()
    Sheets("SujetNC3").Shapes.SelectAll
    Selection.Delete
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
A

Anais0998

XLDnaute Nouveau
JM27 à dit:
Bonjour
et comme cela ?
dans le module de la feuille SujetNC3
Si cela fonctionne on pourra optimiser le code en supprimant si possible les select
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligneDeTraitement As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    If Not Intersect([A99,A104,A109,A114], Target) Is Nothing And Target.Count = 1 Then
       If Target > 0 And Target < 10 Then
        Application.EnableEvents = False
        ligneDeTraitement = Target
        Sheets("ListesEval").Select
        ActiveSheet.Shapes.Range(Array("Picture " & ligneDeTraitement)).Select
        Selection.Copy
        Sheets("SujetNC3").Select
        Target.Rows.Select
        Selection.RowHeight = 41
        Range("B" & Target.Row).Select
        ActiveSheet.Paste
        Selection.ShapeRange.IncrementLeft 355.8
        Selection.ShapeRange.IncrementTop 2.4
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
       End If
    End If
End Sub

et pour éviter de surcharger ta feuille SujetNC3 d'images qui se super-positionneront les unes sur les autres
mettre un bouton pour effacer toutes les shapes
Code: 
Sub Macro1()
    Sheets("SujetNC3").Shapes.SelectAll
    Selection.Delete
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
A

Anais0998

XLDnaute Nouveau
JM27, j'ai testé ton fichier, qui fonctionne parfaitement, mais le même code dans mon fichier ne fonctionne pas.
J'ai fait des captures d'écran avec les formules dans mes cellules, peut-être que tu trouveras pourquoi ça ne fonctionne pas chez moi.

Je t'explique : concernant la capture d'écran de la bdd questions, lorsque je clik 2 fois dans la dernière colonne visible, un comptage du nombre de question sélectionnées est généré dans la 1ère colonne de la bdd. Ensuite, la rechercheV de la feuille sujetnc3 recherche les numéros de question dans cette 1ère colonne de la bdd, ce qui a pour action de transférer les questions et les 3 propositions de réponse dans la feuille sujet. 0 partir de là, une autre formule dans la colonne c de la feuille sujetnc3 génère les 4 numéros de pictos correspondant aux 4 questions santé sécurité. Voilà comment mon fichier fonctionne. J'espère que ça pourra t'aider à comprendre pourquoi ça ne fonctionne pas, car moi je n'y connais pas grand chose et je ne vois pas ce qui cloche ...Merci encore pour ton aide
 

Pièces jointes

  • Capture-FEUILLE-SUJET-AVEC-FORMULES-1.JPG
    Capture-FEUILLE-SUJET-AVEC-FORMULES-1.JPG
    84.8 KB · Affichages: 20
  • FEUILLE-SUJET-AVEC-FORMULE2.JPG
    FEUILLE-SUJET-AVEC-FORMULE2.JPG
    121.2 KB · Affichages: 18
  • Capture-FEUILLE-BDD-QUESTION.JPG
    Capture-FEUILLE-BDD-QUESTION.JPG
    120.6 KB · Affichages: 19
Vote positif 0 Vote négatif
A

Anais332*192

XLDnaute Nouveau
JM27 à dit:
Bonjour
et comme cela ?
dans le module de la feuille SujetNC3
Si cela fonctionne on pourra optimiser le code en supprimant si possible les select
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligneDeTraitement As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    If Not Intersect([A99,A104,A109,A114], Target) Is Nothing And Target.Count = 1 Then
       If Target > 0 And Target < 10 Then
        Application.EnableEvents = False
        ligneDeTraitement = Target
        Sheets("ListesEval").Select
        ActiveSheet.Shapes.Range(Array("Picture " & ligneDeTraitement)).Select
        Selection.Copy
        Sheets("SujetNC3").Select
        Target.Rows.Select
        Selection.RowHeight = 41
        Range("B" & Target.Row).Select
        ActiveSheet.Paste
        Selection.ShapeRange.IncrementLeft 355.8
        Selection.ShapeRange.IncrementTop 2.4
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
       End If
    End If
End Sub

et pour éviter de surcharger ta feuille SujetNC3 d'images qui se super-positionneront les unes sur les autres
mettre un bouton pour effacer toutes les shapes
Code: 
Sub Macro1()
    Sheets("SujetNC3").Shapes.SelectAll
    Selection.Delete
End Sub
Cliquez pour agrandir...
 

Pièces jointes

  • QCM EVALUATION CERTIPHYTO-fichier-test.zip
    965.3 KB · Affichages: 8
Vote positif 0 Vote négatif
A

Anais332*192

XLDnaute Nouveau
Voici enfin le fichier largement allégé on va dire, j'ai supprimé pas mal de choses pour ne garder uniquement de quoi tester un code allégé pour le transfert de mes pictos. Encore merci à tous pour vos propositions et votre aide précieuse, j'espère qu'on pourra mtn trouver une solution. Merci d'avance et bonne soirée.
 
Vote positif 0 Vote négatif
A

Anais332*192

XLDnaute Nouveau
JM27 à dit:
bonjour
désolé mais sans fichier je passe la main
Cliquez pour agrandir...
Bonsoir JM27, par rapport au fichier que j'ai enfin réussi à poster, je m'aperçois que le bouton relié à la macro qui rapatrie les pictos dans la feuille sujet, a disparu (j'ai un peu trop forcé sur le régime pour alléger mon fichier) ... Si ça ne te dérange pas de rajouter un bouton à affecter à la macro "Sub Questions_sante_securite". Merci pour ton aide.
 
Vote positif 0 Vote négatif
C

Compte Supprimé 979

Guest
Bonjour le fil, Anais332*192 ;-)

Voici ton fichier modifié

Tu avais un problème avec le nom du 9ème picto "Image109" au lieu de "Image 109"

A+
 

Pièces jointes

  • QCM EVALUATION CERTIPHYTO-fichier-test.zip
    954.1 KB · Affichages: 10
Vote positif 0 Vote négatif

Discussions similaires

P
  • Question
Microsoft 365 Macro qui plante exel
Réponses
1
Affichages
431
mapomme
mapomme
P
  • Question
XL 2016 Affecter à un bouton plusieurs possibilité
Réponses
3
Affichages
483
Eric KERGRESSE
E
chilo27
  • Question
Autres Simplifier une macro
Réponses
1
Affichages
359
fanch55
fanch55
C
  • Question
Microsoft 365 Arret macro si condition est fausse
Réponses
4
Affichages
565
Chounoé
C
M
  • Question
XL 2010 Insérer image dans une zone de texte
2
Réponses
15
Affichages
1 K
patricktoulon
patricktoulon
A
  • Résolu(e)
XL 2013 Utilisation de plusieurs conditions
Réponses
7
Affichages
1 K
AnjyD
A
M
  • Question
XL 2010 Insérer 3 images
Réponses
11
Affichages
709
madoupa
M
N
  • Question
XL 2021 BESOIN D'aide macro
Réponses
7
Affichages
747
Gégé-45550
Gégé-45550
L
  • Question
XL 2016 Macro et suppressions de lignes
Réponses
9
Affichages
789
fanfan38
fanfan38
A
  • Question
Microsoft 365 boucle macro pour importer des données
2
Réponses
16
Affichages
2 K
Arnaud Legay
A

Membres actuellement en ligne

7 membres et 48 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 719
Messages
2 112 183
Membres
111 455
dernier inscrit
Jacandre