Copier coller une photo en VBA

**MoristO** · 23/11/2016, 14h25

Bonjour Les experts,

J'aurai besoin de votre précieuse aide, je suis entrain de générer une fiche candidat (fenêtre excel ) depuis une liste de candidat avec un simple clic sur le bouton Lance ( en haut a gauche dans l'onglet liste ),mon problème est que je n'arrive pas à copier coller les photos des candidats dans la fiche de chaque Candidat.

Ci-joint le fichier sur lequel je travaille.

Merci de m'aider à corriger/ajuster mon code VBA.Fichier FORUM.xls

**mercatog** · 23/11/2016, 16h02

Dans ta feuille vierge Fiche Candidat tu insères deux contrôles Images ActiveX (Onglet developpeur > insérer > Contrôlre ActiveX) nommés Image1 et Image2
Dans ta feuille Liste tu insère le nom complet de chaque image (Colonnes P et Q)

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
Sub creation_fiche()
Dim DerLigne As Long, i As Long
Dim Feuil As String, Img As String
Dim Ws As Worksheet
 
Application.ScreenUpdating = False
With Worksheets("Liste")
    DerLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 6 To DerLigne
        Feuil = " Candidat " & .Cells(i, 1)
        If Feuil <> "" Then
            If FeuilleExiste(Feuil) Then
                Set Ws = Worksheets(Feuil)
            Else
                Worksheets("Fiche candidat").Copy after:=Worksheets(Worksheets.Count)
                Set Ws = ActiveSheet
                Ws.Name = Feuil
            End If
 
            Img = .Cells(i, 16).Value
            If Dir(Img) <> "" Then Ws.OLEObjects("Image1").Object.Picture = LoadPicture(Img)
            Img = .Cells(i, 17).Value
            If Dir(Img) <> "" Then Ws.OLEObjects("Image2").Object.Picture = LoadPicture(Img)
 
            Ws.Range("K1") = .Cells(i, 1)
            Ws.Range("C7") = .Cells(i, 2)
            Ws.Range("C7") = .Cells(i, 3)
            Ws.Range("C8") = .Cells(i, 4)
            Ws.Range("I2") = .Cells(i, 5)
            Ws.Range("D2") = .Cells(i, 6)
            Ws.Range("C13") = .Cells(i, 7)
            Ws.Range("C14") = .Cells(i, 8)
            Ws.Range("C15") = .Cells(i, 9)
            Ws.Range("I13") = .Cells(i, 10)
            Ws.Range("I14") = .Cells(i, 11)
            Ws.Range("I15") = .Cells(i, 12)
            Ws.Range("B20") = .Cells(i, 13)
            Ws.Range("G23") = .Cells(i, 14)
            Ws.Range("B43") = .Cells(i, 15)
            Ws.Range("I52") = .Cells(i, 18)
            Ws.Range("D52") = .Cells(i, 19)
            Ws.Range("C64") = .Cells(i, 23)
            Ws.Range("C66") = .Cells(i, 24)
            Ws.Range("C68") = .Cells(i, 25)
        End If
    Next i
End With
End Sub
 
Private Function FeuilleExiste(ByVal F As String) As Boolean
 
On Error Resume Next
FeuilleExiste = Worksheets(F).Index
End Function

**MoristO** · 24/11/2016, 18h49

Merci de ton aide !

j'ai eu un message d'erreur ''' If FeuillExiste(Feuil) Then ''' quand j'exécute le programme

Sinon quand tu dis (tu insères le nom complet de chaque image) tu parles de quel nom complet d'image ?

Merci d'avance

**mercatog** · 24/11/2016, 18h59

J'ai changé ta fonction FeuilleExiste, regarde bien

Pour ta question, je veux dire nom + chemin complet des images

PS. pas la peine de coter les réponses

**MoristO** · 25/11/2016, 11h10

Merci ,je n'ai pas fait attention j'ai copié que la premier partie du code.

Sinon dans mon export je n'ai pas le chemin complet, les images sont dans le fichier ,elles ne sont pas stockées dans mon Ordinateur.(fichier joint dans mon premier message )

Merci d'avance et Forza OCK !

**mercatog** · 25/11/2016, 12h08

Voilà, pas besoin d'activeX image

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 creation_fiche()
Dim DerLigne As Long, i As Long
Dim Ws As Worksheet
Dim Feuil As String
Dim Shp As Shape
 
Application.ScreenUpdating = False
With Worksheets("Liste")
    DerLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 6 To DerLigne
        Feuil = " Candidat " & .Cells(i, 1)
        If Feuil <> "" Then
            If FeuilleExiste(Feuil) Then
                Set Ws = Worksheets(Feuil)
                For Each Shp In Ws.Shapes
                    Shp.Delete
                Next Shp
            Else
                Worksheets("Fiche candidat").Copy after:=Worksheets(Worksheets.Count)
                Set Ws = ActiveSheet
                Ws.Name = Feuil
            End If
 
            Ws.Range("K1") = .Cells(i, 1)
            Ws.Range("C7") = .Cells(i, 2)
            Ws.Range("C7") = .Cells(i, 3)
            Ws.Range("C8") = .Cells(i, 4)
            Ws.Range("I2") = .Cells(i, 5)
            Ws.Range("D2") = .Cells(i, 6)
            Ws.Range("C13") = .Cells(i, 7)
            Ws.Range("C14") = .Cells(i, 8)
            Ws.Range("C15") = .Cells(i, 9)
            Ws.Range("I13") = .Cells(i, 10)
            Ws.Range("I14") = .Cells(i, 11)
            Ws.Range("I15") = .Cells(i, 12)
            Ws.Range("B20") = .Cells(i, 13)
            Ws.Range("G23") = .Cells(i, 14)
            Ws.Range("B43") = .Cells(i, 15)
            Ws.Range("I52") = .Cells(i, 18)
            Ws.Range("D52") = .Cells(i, 19)
            Ws.Range("C64") = .Cells(i, 23)
            Ws.Range("C66") = .Cells(i, 24)
            Ws.Range("C68") = .Cells(i, 25)
            CopyImage .Cells(i, 16), Ws.Range("B28")
            CopyImage .Cells(i, 17), Ws.Range("H28")
        End If
    Next i
End With
End Sub
 
Private Function FeuilleExiste(ByVal F As String) As Boolean
 
On Error Resume Next
FeuilleExiste = Worksheets(F).Index
End Function
 
 
Private Sub CopyImage(ByVal Img As String, ByVal Rng As Range)
 
On Error GoTo Fin
Worksheets("Liste").Shapes(Img).Copy
Rng.PasteSpecial
 
With Rng.Worksheet
    With .Shapes(.Shapes.Count)
        .Left = Rng.Left
        .Top = Rng.Top
        .Width = 4 * Rng.Width
        .Height = 11 * Rng.Height
    End With
End With
Fin:
End Sub

**joe.levrai** · 25/11/2016, 12h28

Bonjour,

rien à voir avec la tambouille réelle de la discussion, mais ceci est-il normal ?

Code :

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

1
2
Ws.Range("C7") = .Cells(i, 2)
Ws.Range("C7") = .Cells(i, 3)

**mercatog** · 25/11/2016, 12h36

Joe la réponse est non ce n'est pas normal

**MoristO** · 25/11/2016, 14h05

Merci beaucoup mercatog ! ca marche à merveille.

**mercatog** · 25/11/2016, 15h11

MoristO

Remplace la sub CopyImage par celle ci (pour éviter le 4 et le 11 multiplicateurs)

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
Private Sub CopyImage(ByVal Img As String, ByVal Rng As Range)
 
On Error GoTo Fin
Worksheets("Liste").Shapes(Img).Copy
Rng.PasteSpecial
 
With Rng.Worksheet
    With .Shapes(.Shapes.Count)
        .Left = Rng.Left
        .Top = Rng.Top
        .Width = Rng.MergeArea.Width
        .Height = Rng.MergeArea.Height
    End With
End With
Fin:
End Sub

**MoristO** · 19/02/2017, 20h12

Merci à vous tous !

Copier coller une photo en VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager