Combiner 2 macros excel

Version imprimable

Bonjour,

Je cherche comment combiner 2 macros xls:

Le premier code consiste à copier des cellules depuis un tableau de valeurs bruts (non mis en forme) vers un autre onglet contenant un tableau mis en forme cette fois.

Une ligne de mon tableau brut fabrique un onglet dans lequel il place les valeurs dans une cellule précise.

Il fabrique autant d'onglets que de lignes.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub Onglet_auto()
'
 
Dim nb As Integer 'compteur
nb = 2
Dim CLT As Integer 'nombre de ligne du tableau
CLT = 4
 
'declaration des valeurs des champs du tableau
Dim commune As String
Dim intervenant As String
Dim Localisation_X As String
Dim Localisation_Y As String
Dim Date_visite As String
Dim Commentaire As String
 
'ect.. a creer tout les champs utiles
 
Do
 
commune = Sheets("SYNTHESE").Cells(nb, 1).Value
intervenant = Sheets("SYNTHESE").Cells(nb, 2).Value
Localisation_X = Sheets("SYNTHESE").Cells(nb, 3).Value
Localisation_Y = Sheets("SYNTHESE").Cells(nb, 4).Value
Date_visite = Sheets("SYNTHESE").Cells(nb, 5).Value
Commentaire = Sheets("SYNTHESE").Cells(nb, 6).Value
 
'suppression onglet preexistant (l'onglet s'appele "ATHIS MONS CENTRAL ATM00240")
   On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(commune).Delete
    Application.DisplayAlerts = True
 
'copie de l'onglet model
   Sheets("feuil1").Select
    Cells.Select
    Selection.Copy
'ajout nouvel onglet
   Sheets.Add before:=ActiveSheet
    Cells.Select
    ActiveSheet.Paste
'Changement nom onglet
   ActiveSheet.Select
    ActiveSheet.Name = commune
 
'ecriture des données
   Range("B3").Select
    ActiveCell.FormulaR1C1 = commune
 
    Range("B4").Select
    ActiveCell.FormulaR1C1 = intervenant
 
    Range("D8").Select
    ActiveCell.FormulaR1C1 = Localisation_X
 
    Range("D9").Select
    ActiveCell.FormulaR1C1 = Localisation_Y
 
    Range("F4").Select
    ActiveCell.FormulaR1C1 = Date_visite
 
    Range("A24").Select
    ActiveCell.FormulaR1C1 = Commentaire
 
 
 
 
 
nb = nb + 1
 
Loop Until nb > CLT
 
End Sub

J'aimerai rajouter des photos dans certaines cellules.
Ces photos sont situées dans un répertoire et le lien de ces photos est présent dans un des champs de mon tableau initial.

J'ai trouvé ce bout de code qui fait le job:
Ce code va chercher une image située dans un répertoire et vient la mettre dans une cellule.

Ce que je souhaiterai faire serait d'ajouter ce deuxième code au premier pour faire cela d'un coup.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Affiche_Image()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String                   ' Contiendra le nom de l'image
Dim Lg As Long                        ' Numéro de la dernière ligne colonne B
 
  Set Ws = Sheets("Feuil1")                                           ' Nom de la feuille
 
  Application.ScreenUpdating = False                                  ' Interdit le raffraîchissement d'écran
 
  Efface_Images
 
  With Ws
 
    For Lg = 1 To .Range("B1").End(xlUp).Row                      ' Parcourt de toute la colonne B
 
      Image = ThisWorkbook.Path & "\Trains\" & .Cells(Lg, "B")        ' Répertoire à actualiser
 
      On Error Resume Next                                            ' On s'affranchit des erreurs
      With .Pictures.Insert(Image).ShapeRange                         ' On insère l'image dont le nom est en colonne B
        .LockAspectRatio = msoFalse                                   ' On peut la redimmensionner comme on veut
        .Left = Ws.Cells(Lg, "A").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "A").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "A").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "A").Height                            ' hauteur
      End With
      If Err.Number > 0 Then                                          ' Si une erreur (image non présente)
        MsgBox .Cells(Lg, "B") & vbCr & "Image inexistante"           ' On le signale
      End If
    Next Lg
  End With
End Sub

Merci pour le coup de main et les conseils!

Bonjour,

1) Ton premier code mériterait d'être simplifié :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 Option Explicit Sub Onglet_auto() ' Dim wsh As Worksheet 'feuille Dim n°L As Long 'numéro de ligne Dim d°L As Long 'derniere ligne Dim commune As String 'commune Set wsh = Worksheets("SYNTHESE") d°L = wsh.Cells(Rows.Count, "A").End(xlUp).Row For n°L = d°L To 2 Step -1 commune = wsh.Cells(n°L, "A").Value ' suppression onglet commune preexistant On Error Resume Next Application.DisplayAlerts = False Sheets(commune).Delete Application.DisplayAlerts = True On Error GoTo 0 ' copie de l'onglet modèle Worksheets("feuil1").Copy before:=Worksheets(1) With ActiveSheet .Name = commune ' écriture des données .Range("B3").Formula = commune .Range("B4").Formula = wsh.Cells(n°L, "B").Value 'intervenant .Range("D8").Formula = wsh.Cells(n°L, "C").Value 'Localisation_X .Range("D9").Formula = wsh.Cells(n°L, "D").Value 'Localisation_Y .Range("F4").Formula = wsh.Cells(n°L, "E").Value 'Date_visite .Range("A24").Formula = wsh.Cells(n°L, "F").Value 'Commentaire End With Next n°L wsh.Move before:=Worksheets(1) End Sub
2) Dans le second code, il manque une ligne entre les lignes 28 et 29 :

Code:

On Error Goto 0

Pour rétablir le gestionnaire d'erreur pour le reste du code.

3) Tu dis que le second code « fait le job », ce qui m'étonne car :
- il place les images dans la feuille "feuil1" qui est modèle utilisé pour créer la feuille de chaque commune.
- il cherche les images dont le nom est en B (en B3 la commune et en B4 l'intervenant ???)
Si ça te convient, il suffit d'ajouter au début de la procédure Onglet_auto :

Code:

Call Affiche_Image

Sinon expliques précisément ce que tu voudrais

05/01/2018, 10h12
Fabyfabzzz

Bonjour,

Ton premier code "simplifié" marche très bien merci.

Je voudrais rajouter à cela 2 images (.jpeg) dans les cellule B15 et F15 dont les noms sont placés dans les champs "photo1" et "photo2" (colonne G et H) dans l'onglet "synthèse"

Les images sont situées dans un dossier "TOTO" à la racine.

Merci beaucoup pour ton aide

Re,

Je n'ai pas bien compris ce que tu appelles "champ" :

Citation:

Envoyé par Fabyfabzzz

... dont les noms sont placés dans les champs "photo1" et "photo2" (colonne G et H) dans l'onglet "synthèse"

Pour moi un champ, ça représente soit :
- les valeurs contenues dans une colonne d'une table d'une base de données dont le nom est le titre de la colonne
- une de ces valeurs dans un formulaire représentant un des enregistrements (une des lignes) de cette table
Dans ton explication, tu parles bien des colonnes G et H, mais il n'y a que 2 photos à mettre en place en B15 et F15 c'est pourquoi je comprend pas que emploies le terme "champ".
J'ai donc supposé que par "champ" tu veux dire "plage nommée" c'est à dire que tu as donné le nom Photo1 à la cellule qui contient le nom de la photo 1 et Photo 2 à l'autre.

Voici une proposition :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
Option Explicit
Sub Onglet_auto()
'
Dim wsh As Worksheet  'feuille
Dim commune$          'commune
Dim n°L&              'numéro de ligne
Dim d°L&              'derniere ligne
 
Set wsh = Worksheets("SYNTHESE")
d°L = wsh.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For n°L = d°L To 2 Step -1
  commune = wsh.Cells(n°L, "A").Value
  ' suppression onglet commune preexistant
  On Error Resume Next
    Application.DisplayAlerts = False
      Sheets(commune).Delete
    Application.DisplayAlerts = True
  On Error GoTo 0
  ' copie de l'onglet modèle
  Worksheets("feuil1").Copy before:=Worksheets(1)
  With ActiveSheet
    .Name = commune
    ' écriture des données
    .Range("B3").Formula = commune
    .Range("B4").Formula = wsh.Cells(n°L, "B").Value  'intervenant
    .Range("D8").Formula = wsh.Cells(n°L, "C").Value  'Localisation_X
    .Range("D9").Formula = wsh.Cells(n°L, "D").Value  'Localisation_Y
    .Range("F4").Formula = wsh.Cells(n°L, "E").Value  'Date_visite
    .Range("A24").Formula = wsh.Cells(n°L, "F").Value 'Commentaire
  End With
Next n°L
wsh.Move before:=Worksheets(1)
Call Inserer_images
Application.ScreenUpdating = True
 
End Sub
Sub Inserer_images()
' Insère 2 images (jpeg) dans les cellule B15 et F15 dont les noms sont placés dans
' les cellules nommées "photo1" et "photo2" de l'onglet "SYNTHESE"
'
Dim wsh As Worksheet
Dim dst As Range
Dim dossier$
Dim nom$
  Set wsh = Worksheets("SYNTHESE")
  Call Effacer_images(wsh)
  Application.ScreenUpdating = False
  dossier = ThisWorkbook.Path & "\"  ' à adapter
  ' Insérer la photo1
  nom = wsh.Range("Photo1").Text     'si la cellule Photo1 n'est pas nommée : wsh.Range("G15").Text
  Set dst = wsh.Range("B15")
  Call Inserer_image(nom, dossier, dst)
  ' Insérer la photo2
  nom = wsh.Range("Photo2").Text
  Set dst = wsh.Range("F15")
  Call Inserer_image(nom, dossier, dst)
  Application.ScreenUpdating = True
End Sub
Sub Effacer_images(Optional feuille As Worksheet)
' Supprime toutes les images d'un feuille de calcul
' Arguments : feuille             [in]  Feuille de calcul concernée
'
Dim shp As Excel.Shape
  If feuille Is Nothing Then Set feuille = ActiveSheet
  Application.ScreenUpdating = False
  For Each shp In feuille.Shapes
    If shp.Type = msoPicture Then
      shp.Delete
    End If
  Next shp
  Application.ScreenUpdating = True
End Sub
Private Sub Inserer_image(nomImage$, repImages$, celCible As Range)
' Insère une image depuis un fichier image jpeg vers une cellule
' Arguments : nomImage            [in]  nom de l'image jpeg (avec ou sans extension)
'             repImages           [in]  Répertoire contenant les images
'             celCible            [in]  Cellule recevant l'image
'
Dim shr As Excel.ShapeRange
  If Dir(repImages & nomImage & ".jpg") <> "" Then nomImage = nomImage & ".jpg"
  If Dir(repImages & nomImage & ".jpeg") <> "" Then nomImage = nomImage & ".jpeg"
  If Dir(repImages & nomImage) = "" Then
    MsgBox "L'image " & nomImage & " n'existe pas dans le dossier :" & vbCrLf & repImages
  Else
  Set shr = celCible.Parent.Pictures.Insert(repImages & nomImage).ShapeRange
  With shr
    .Name = Mid(nomImage, 1, InStrRev(nomImage, ".") - 1)
    .LockAspectRatio = msoFalse
    .Left = celCible.Left
    .Top = celCible.Top
    .Width = celCible.Width
    .Height = celCible.Height
  End With
End If
End Sub

05/01/2018, 15h14
Fabyfabzzz

1 pièce(s) jointe(s)

Oui le Photo1 et Photo2 sont bien les noms des colonnes.
Les attributs contenus dans ces colonnes sont les titres des photos. (ex: "tutu.jpeg")

Je pense qu'en diffusant l'Excel vous comprendrez mieux le problème.

Les photos à placer dans les cellules sont toutes différentes.

Pièce jointe 339789

Merci

Re,

Tu avais simplement pas précisé sur quelle feuille se trouvent B15 et F15,
pas sur Synthèse comme ta phrase pouvait le laisser supposer.

Finalement c'est plus simple :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Option Explicit
Sub Onglet_auto()
'
Dim wsh As Worksheet  'feuille
Dim images$           'dossier des images
Dim commune$          'commune
Dim n°L&              'numéro de ligne
Dim d°L&              'derniere ligne
 
Set wsh = Worksheets("SYNTHESE")
d°L = wsh.Cells(Rows.Count, "A").End(xlUp).Row
images = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
For n°L = d°L To 2 Step -1
  commune = wsh.Cells(n°L, "A").Value
  ' suppression onglet commune preexistant
  On Error Resume Next
    Application.DisplayAlerts = False
      Sheets(commune).Delete
    Application.DisplayAlerts = True
  On Error GoTo 0
  ' copie de l'onglet modèle
  Worksheets("feuil1").Copy before:=Worksheets(1)
  With ActiveSheet
    .Name = commune
    ' écriture des données
    .Range("B3").Formula = commune
    .Range("B4").Formula = wsh.Cells(n°L, "B").Value  'intervenant
    .Range("D8").Formula = wsh.Cells(n°L, "C").Value  'Localisation_X
    .Range("D9").Formula = wsh.Cells(n°L, "D").Value  'Localisation_Y
    .Range("F4").Formula = wsh.Cells(n°L, "E").Value  'Date_visite
    .Range("A24").Formula = wsh.Cells(n°L, "F").Value 'Commentaire
    Call Effacer_images(wsh)
    Call Inserer_image(wsh.Cells(n°L, "G").Text, images, .Range("B15").MergeArea)
    Call Inserer_image(wsh.Cells(n°L, "H").Text, images, .Range("F15").MergeArea)
  End With
Next n°L
wsh.Move before:=Worksheets(1)
'Call Inserer_images
Application.ScreenUpdating = True
 
End Sub
Sub Effacer_images(Optional feuille As Worksheet)
' Supprime toutes les images d'un feuille de calcul
' Arguments : feuille             [in]  Feuille de calcul concernée
'
Dim shp As Excel.Shape
Dim scr As Boolean
  If feuille Is Nothing Then Set feuille = ActiveSheet
  scr = Application.ScreenUpdating
  Application.ScreenUpdating = False
  For Each shp In feuille.Shapes
    If shp.Type = msoPicture Then
      shp.Delete
    End If
  Next shp
  Application.ScreenUpdating = scr
End Sub
Private Sub Inserer_image(nomImage$, repImages$, celCible As Range)
' Insère une image depuis un fichier image jpeg vers une cellule
' Arguments : nomImage            [in]  nom de l'image jpeg (avec ou sans extension)
'             repImages           [in]  Répertoire contenant les images
'             celCible            [in]  Cellule recevant l'image
'
Dim shr As Excel.ShapeRange
  If Dir(repImages & nomImage & ".jpg") <> "" Then nomImage = nomImage & ".jpg"
  If Dir(repImages & nomImage & ".jpeg") <> "" Then nomImage = nomImage & ".jpeg"
  If Dir(repImages & nomImage) = "" Then
    MsgBox "L'image " & nomImage & " n'existe pas dans le dossier :" & vbCrLf & repImages
  Else
  Set shr = celCible.Parent.Pictures.Insert(repImages & nomImage).ShapeRange
  With shr
    .Name = Mid(nomImage, 1, InStrRev(nomImage, ".") - 1)
    .LockAspectRatio = msoFalse
    .Left = celCible.Left
    .Top = celCible.Top
    .Width = celCible.Width
    .Height = celCible.Height
  End With
End If
End Sub

05/01/2018, 17h15
davidbd

Message à supprimer.
05/01/2018, 17h19
Fabyfabzzz

Merci beaucoup Patrice! Ça fait exactement ce que souhaitais.
Bravo;)