Discussion :

[flomos]

Bonjour tout le monde,

Grâce à votre aide, j'ai réussi à réaliser un publipostage au sein d'un même fichier Excel.
Je reviens vers vous pour faire évoluer cette (simple) macro.
Ma macro actuel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
'Boucle de publipostage'
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Sheets("Modele").Copy Before:=Sheets("Feuil3")
ActiveSheet.Name = ("N°" & Sheets("BdD").Range("D" & i))
Range("B3") = Sheets("BdD").Cells(i, 1)
Range("B4") = Sheets("BdD").Cells(i, 2)
Range("B5") = Sheets("BdD").Cells(i, 3)
Range("C2") = Sheets("BdD").Cells(i, 4)
Range("B6") = Sheets("BdD").Cells(i, 5)
Range("B7") = Sheets("BdD").Cells(i, 6)
 
Next i

Résultat obtenu :


Je souhaite maintenant que ma macro intègre la gestion des photos. Pour chaque feuille, j'ai une photo nommé "N"& Sheets("BdD").Range("D" & i) dans un dossier spécifique.
J'aimerais donc qu'au lancement de la macro, celle ci me demande l'emplacement du dossier regroupant les images, puis qu'elle les insère dans chaque feuille.
J'ai trouvé sur internet, le script suivant. Le problème de ce script, c'est qu'il est nécessaire de stipuler, pour chaque image, le chemin exacte en la sélectionnant.

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
Public Sub insere_image()
Dim ficimg As Variant
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")  ' choix nom du fichier
    ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
    End With
End Sub

Je suppose que la solution est dans première ligne mais je ne sais pas comment m'y prendre...

Merci par avance

[pijaku]

Bonjour,

Ici, tu n'as pas besoin de sélectionner un fichier, mais un répertoire.
Voir --ICI--

Ensuite ne te reste plus qu'à boucler sur ledit répertoire : Voir ICI

[flomos]

En combianant l'ensemble des infos que j'ai pu trouvé ainsi que les conseils de @pijaku, j'ai produit ce code.

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
Sélection du répertoire où se situe les images'
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim Chemin As String, Fichier As String
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
 
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
 
'Boucle de publipostage'
For i = 2 To derlig
Sheets("Modele").Copy Before:=Sheets("Feuil3")
ActiveSheet.Name = ("N°" & Sheets("BdD").Range("D" & i))
Range("B3") = Sheets("BdD").Cells(i, 1)
Range("B4") = Sheets("BdD").Cells(i, 2)
Range("B5") = Sheets("BdD").Cells(i, 3)
Range("C2") = Sheets("BdD").Cells(i, 4)
Range("B6") = Sheets("BdD").Cells(i, 5)
Range("B7") = Sheets("BdD").Cells(i, 6)
Range("C3:D7") = Dir(Chemin & "N" & Sheets("BdD").Range("D" & i) & ".jpg")
ActiveSheet.Pictures.Insert(Fichier).Select ' insertion'
With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width       ' largeur de la cellule
End With
With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
Next i

Le soucis, c'est que j'ai un message d'erreur m'indiquant qu'il y a un "Next sans For"... Quelle erreur ai-je commis ?

(Et au faite merci pour le lien vers les FAQ, je ne savais qu'ils renfermaient autant de trésors !)

[unparia]

Bonjour
où est le End With qui ferme ce bloc With :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
Next i

???
C'est lui, qui manque et provoque le message d'erreur reçu.

[flomos]

Effectivement le message d'erreur provenait bien de ça...

Mon code ne fait plus de message d'erreur mais il ne présente pas non plus le résultat attendu... L'insertion de l'image ne se réalise pas.

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
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim Chemin As String, Fichier As String
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
 
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
 
'Boucle de publipostage'
For i = 2 To derlig
Sheets("Modele").Copy Before:=Sheets("Feuil3")
ActiveSheet.Name = ("N°" & Sheets("BdD").Range("D" & i))
Range("B3") = Sheets("BdD").Cells(i, 1)
Range("B4") = Sheets("BdD").Cells(i, 2)
Range("B5") = Sheets("BdD").Cells(i, 3)
Range("C2") = Sheets("BdD").Cells(i, 4)
Range("B6") = Sheets("BdD").Cells(i, 5)
Range("B7") = Sheets("BdD").Cells(i, 6)
Fichier = Dir(Chemin & Sheets("BdD").Range("D" & i) & ".png")
Range("C3:D7").Activate
ActiveSheet.Pictures.Insert(Fichier).Select ' insertion'
With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width       ' largeur de la cellule
End With
With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
 
End With
 
Next i

Une idée ?

[romainorleans]

Bonsoir,

Tu as déclaré et défini derlig? Je ne le vois pas dans le code.