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 : 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
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 : 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
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!