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

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
 

JBARBE

XLDnaute Barbatruc
Bonjour à tous toutes,
Faire des boucles i j k de 1 à 9 !
VB:
Dim i As Long
For i = 1 To 9
If Range("C99").Value = i 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
Next i
Code:
Dim j As Long

For j= 1 To 9
If Range("C114").Value = j 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
End If
Next j
VB:
Dim k As Long

For k = 1 To 9
If Range("C104").Value = k 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
End If
Next k
bonne journée !
 
Dernière édition:

JBARBE

XLDnaute Barbatruc
Re,
ou bien :
VB:
If Range("C104").Value = 1 or Range("C104").Value = 2 or Range("C104").Value = 3 _
or Range("C104").Value = 4 or Range("C104").Value = 5 or Range("C104").Value = 6 _
or Range("C104").Value = 7 or Range("C104").Value = 8 or Range("C104").Value = 9 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
end if
Code:
If Range("C109").Value = 1 or Range("C109").Value = 2 or Range("C109").Value = 3 _
or Range("C109").Value = 4 or Range("C109").Value = 5 or Range("C109").Value = 6 _
or Range("C109").Value = 7 or Range("C109").Value = 8 or Range("C109").Value = 9 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
end if
Code:
If Range("C114").Value = 1 or Range("C114").Value = 2 or Range("C114").Value = 3 _
or Range("C114").Value = 4 or Range("C114").Value = 5 or Range("C114").Value = 6 _
or Range("C114").Value = 7 or Range("C114").Value = 8 or Range("C114").Value = 9 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
end if
 

ChTi160

XLDnaute Barbatruc
Bonjour Anais0998
Bonjour JBARRE ,Le Forum
Peut être aussi
Ex : pour la Cellule C104 ,Post #3
VB:
If Range("C104").Value >= 1 And Range("C104").Value <= 9 Then
a voir
jean marie
 

JM27

XLDnaute Impliqué
Bonsoir
Pour pouvoir faire une boucle correcte ; il va falloir renommer toutes tes pictures
La picture 46 sera la 1
La picture 44 sera la 2
La Picture 50 sera la 3
La picture 17 sera la 4
La picture 40 sera la 5
La picture 39 sera la 6
La picture 42 sera la 7
La picture 10 sera la 8
La picture 48 sera la 9

Si ces numéro ( de 1 à 9 ) sont déja utilisés , tu peux prendre d'autres n° à condition qu'ils se suivent ( par exemple 101 à 109)

Un fichier joint sera bien plus pratique:(
 
Dernière édition:

ChTi160

XLDnaute Barbatruc
Re
Bonsoir JM27

et peut être un truc du genre
VB:
Sub test()'Non fonctionnelle
x = 1: i=1 'Pour l'exemple
With Worksheets("SujetNC3")
oCell = Application.Choose(i, "C99","C104", "C109", "C114")
x = .Range(oCell).Value
If x >= 1 And x <= 9 Then StrShape = Application.Choose(x, "Picture 1", "Picture 2", "Picture 3", "Picture 4", "Picture 5", "Picture 6", "Picture 7", "Picture 8", "Picture 9")
Sheets("ListesEval").Shapes.Range(StrShape).Copy
' Etc Etc
With .Range(oCell)
     .EntireRow.RowHeight = 41
     .Offset(0, 1).Paste
     .ShapeRange.IncrementLeft 355.8
     .ShapeRange.IncrementTop 2.4
End With
End With
End Sub
Non teste car pas de fichier Lol
jean marie
 
Dernière édition:

Anais0998

XLDnaute Nouveau
Bonjour JBARBE,
Merci bcp pour votre réponse rapide. Je vais tester tout des que possible. Belle journée à vous.
Bonjour à tous toutes,
Faire des boucles i j k de 1 à 9 !
VB:
Dim i As Long
For i = 1 To 9
If Range("C99").Value = i 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
Next i
Code:
Dim j As Long

For j= 1 To 9
If Range("C114").Value = j 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
End If
Next j
VB:
Dim k As Long

For k = 1 To 9
If Range("C104").Value = k 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
End If
Next k
bonne journée !
 

Anais0998

XLDnaute Nouveau
désolée fausse manip, je disais que mon fichier ne passe pourtant , il n'est pourtant pas très lourd (1309 ko).

Je n'ai pas encore testé tous les codes qui ont été postés, mais j'ai un doute quant au résultat c
 

Anais0998

XLDnaute Nouveau
car la difficulté majeure est qu'il faut que; par exemple pour la première des 4 questions "santé sécurité", :
si C9 = 1 il faut insérer le le picto 1, si C9 = 2 il faut insérer le picto 2, et ainsi de suite, et comme ça pour chacune des 4 questions du thème "santé sécurité". Or, mais peut-être que je me trompe, les boucles de 1 à 9 insèrent le même picto.

Si vous voyez un autre moyen pour que j'envoie mon fichier je suis preneuse, en attendant je vais tester chaque code et je vous dis ce qu'il en est.

Merci encore
 

Anais0998

XLDnaute Nouveau
Bonsoir
Pour pouvoir faire une boucle correcte ; il va falloir renommer toutes tes pictures
La picture 46 sera la 1
La picture 44 sera la 2
La Picture 50 sera la 3
La picture 17 sera la 4
La picture 40 sera la 5
La picture 39 sera la 6
La picture 42 sera la 7
La picture 10 sera la 8
La picture 48 sera la 9

Si ces numéro ( de 1 à 9 ) sont déja utilisés , tu peux prendre d'autres n° à condition qu'ils se suivent ( par exemple 101 à 109)

Un fichier joint sera bien plus pratique:(
 

Anais0998

XLDnaute Nouveau
Bonjour JM27 et merci bcp pour votre aide. J'ai essayé d'insérer un fichier test mais ça ne passe pas. Comme je répondais à JBARBE, je vais tester tous ces codes mais j'ai un doute quant au résultat, car pour le transfert des picto dans le sujet, par exemple : SI C99 = 1 transfert du picto 1; si C99 = 2 alors transfert du picto 2 et ainsi de suite pour les 9 pictos et rebelote pour chacune des 4 questions "santé sécurité". Si vous connaissez un autre moyen de faire passer mon fichier je suis preneuse. Je vous tiens au courant pour l'essai des codes. Merci encore
 

Anais0998

XLDnaute Nouveau
Re
Bonsoir JM27

et peut être un truc du genre
VB:
Sub test()'Non fonctionnelle
x = 1: i=1 'Pour l'exemple
With Worksheets("SujetNC3")
oCell = Application.Choose(i, "C99","C104", "C109", "C114")
x = .Range(oCell).Value
If x >= 1 And x <= 9 Then StrShape = Application.Choose(x, "Picture 1", "Picture 2", "Picture 3", "Picture 4", "Picture 5", "Picture 6", "Picture 7", "Picture 8", "Picture 9")
Sheets("ListesEval").Shapes.Range(StrShape).Copy
' Etc Etc
With .Range(oCell)
     .EntireRow.RowHeight = 41
     .Offset(0, 1).Paste
     .ShapeRange.IncrementLeft 355.8
     .ShapeRange.IncrementTop 2.4
End With
End With
End Sub
Non teste car pas de fichier Lol
jean marie
Re
Bonsoir JM27

et peut être un truc du genre
VB:
Sub test()'Non fonctionnelle
x = 1: i=1 'Pour l'exemple
With Worksheets("SujetNC3")
oCell = Application.Choose(i, "C99","C104", "C109", "C114")
x = .Range(oCell).Value
If x >= 1 And x <= 9 Then StrShape = Application.Choose(x, "Picture 1", "Picture 2", "Picture 3", "Picture 4", "Picture 5", "Picture 6", "Picture 7", "Picture 8", "Picture 9")
Sheets("ListesEval").Shapes.Range(StrShape).Copy
' Etc Etc
With .Range(oCell)
     .EntireRow.RowHeight = 41
     .Offset(0, 1).Paste
     .ShapeRange.IncrementLeft 355.8
     .ShapeRange.IncrementTop 2.4
End With
End With
End Sub
Non teste car pas de fichier Lol
jean marie
 

Anais0998

XLDnaute Nouveau
Bonjour ChTi160 et merci bcp pour votre aide. J'ai essayé de transmettre un fichier test mais ça ne passe pas. Comme je répondais à JBARBE, je vais tester tous ces codes mais j'ai un doute quant au résultat, car pour le transfert des pictos dans le sujet, par exemple : SI C99 = 1 transfert du picto 1; si C99 = 2 alors transfert du picto 2 et ainsi de suite pour les 9 pictos et rebelote pour chacune des 4 questions "santé sécurité". Si vous connaissez un autre moyen de faire passer mon fichier je suis preneuse. Je vous tiens au courant pour l'essai des codes. Merci encore
 

ChTi160

XLDnaute Barbatruc
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
 

Anais0998

XLDnaute Nouveau
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
 

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
 

Fichiers joints

JM27

XLDnaute Impliqué
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:

JM27

XLDnaute Impliqué
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:

Discussions similaires


Haut Bas