Sujet Précédent Sujet Suivant

VBA conditions if pour insertion de photos depuis un répertoire

Fermé
didom - 28 août 2015 à 09:24
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 - 31 août 2015 à 19:48
Bonjour, je plante sur mon dévelloppement de macro VBA pour insertion automatique de photos.
Je reprends depuis le début:
j'ai mis en place une macro afin d'éditer en automatique des fiches de données techniques.
Pour cela, mon fichier comporte 2 onglets, 1 pour la base de données et l'autre pour 1 modèle à remplir.
les données, sous forme de lignes sont remplies si l'on cache la 1ere colonne et que l'on lance la macro. Cette dernière va récupérer les données de la ligne et les insérer dans des cellules particulières du modèle en créant 1 troisième feuille. Tout ceci fonctionne bien.
Je souhaite ensuite insérer une photo également avec cette même macro. Les photos sont nommés avec la même orthographe que les champs de la 3eme colonne qui s'appelle "ID unique".
La macro éditée arrive à insérer les photos mais la ou je plante c'est sur la formule si il ne trouve pas la photo, je souhaite avoir un message m'informant "photo non trouvée, édition fiche impossible" et qu'il supprime le 3eme onglet généré.
s'il trouve la photo, il édite la fiche normalement.

voici ma formaule VBA actuel:
------------------------------------------------------------------------------------
Sub Rapport()

Ouvrir_PDF = MsgBox("Voulez-vous ouvrir les PDF après l'exécution de la macro ?", vbYesNo, "Question")
If Ouvrir_PDF = vbYes Then Ouvrir_PDF = True
If Ouvrir_PDF = vbNo Then Ouvrir_PDF = False

'debut = Timer
Application.ScreenUpdating = False


Dim Nombre_de_rapports_a_imprimer As Integer 'jusqu'à 32 767
Dim Ligne_Max As Integer
Dim Nom_du_workbook As String
Dim Message_de_fin As String
Dim Derniere_ligne As Integer
Dim I As Integer
Dim Groupe_inspecteur As String
Dim ID_unique As String
Dim Chemin_du_workbook As String

Nombre_de_rapports_a_imprimer = 0
Ligne_Max = 10000

Nom_du_workbook = ActiveWorkbook.Name
Chemin_du_workbook = ActiveWorkbook.Path
Derniere_ligne = Workbooks(Nom_du_workbook).Sheets("Liste LG").Range("A" & Ligne_Max).End(xlUp).Row

'Si aucune croix on ferme
If Derniere_ligne = 1 Then
Message_de_fin = "Aucune croix."
GoTo Label_message_de_fin
End If

'boucle sur toutes les lignes pour détecter le nombre de rapports à imprimerles croix
For I = 9 To Derniere_ligne
If Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 1).Value <> "" Then

Sheets("Modele").Copy After:=Sheets(2)


ID_unique = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 3).Value
ActiveSheet.Name = ID_unique

'Remplissage Unité
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(3, 10).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 2).Value
'Remplissage Repère du niveaux
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(4, 10).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 3).Value
'Remplissage Repère Equipement
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(5, 10).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 4).Value
'Remplissage Constructeur
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(6, 10).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 5).Value
'Remplissage Type
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(7, 10).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 6).Value
'Remplissage Rév
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(5, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 7).Value
'Remplissage Date
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(5, 5).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 8).Value
'Remplissage Par
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(5, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 9).Value
'Remplissage Objet
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(5, 7).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 10).Value
'Remplissage Fluide
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(11, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 11).Value
'Remplissage PMS
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(12, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 12).Value
'Remplissage Température de service
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(13, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 13).Value
'Remplissage Pression d'épreuve
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(14, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 14).Value
'Remplissage Etat liquide_vapeur
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(15, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 15).Value
'Remplissage Type de niveaux
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(19, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 16).Value
'Remplissage Type de glace
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(20, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 17).Value
'Remplissage Dimension S
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(21, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 18).Value
'Remplissage Dimension K
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(22, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 19).Value
'Remplissage Dimension M
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(23, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 20).Value
'Remplissage glace-dimension
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(24, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 21).Value
'Remplissage SAP-identifiant glaces
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(24, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 22).Value
'Remplissage nbre glaces
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(25, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 23).Value
'Remplissage protection MIKA
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(26, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 24).Value
'Remplissage SAP-joint MIKA
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(26, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 25).Value
'Remplissage Joints d'appuis
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(27, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 26).Value
'Remplissage SAP-identifiant joints d'appuis
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(27, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 27).Value
'Remplissage Type de robinets
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(35, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 28).Value
'Remplissage Modèle de robinet
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(36, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 29).Value
'Remplissage Matière
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(37, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 30).Value
'Remplissage Siège
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(38, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 31).Value
'Remplissage SAP identifiant robinet
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(36, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 32).Value
'Remplissage Dispositif de sécurité
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(39, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 33).Value
'Remplissage Joint d'étanchéité
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(40, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 34).Value
'Remplissage SAP-identifiant joint d'étanchéité
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(40, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 35).Value
'Remplissage Typde de boulonnerie
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(41, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 36).Value
'Remplissage Nbre de boulons TF etriers
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(42, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 37).Value
'Remplissage longueur boulons TF cavaliers
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(43, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 38).Value
'Remplissage tracage
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(51, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 39).Value
'Remplissage isolant
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(52, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 40).Value
'Remplissage observations
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(53, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 41).Value
'Remplissage Eclairé
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(54, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 42).Value
'Remplissage Type d'éclairage
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(55, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 43).Value
'Remplissage Alimentation
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(56, 4).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 44).Value
'Remplissage DN raccord process
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(57, 5).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 45).Value
'Remplissage PN raccord process
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(57, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 46).Value
'Remplissage DN raccord purge
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(58, 5).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 47).Value
'Remplissage PN raccord purge
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(58, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 48).Value
'Remplissage DN raccord event
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(59, 5).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 49).Value
'Remplissage PN raccord event
Workbooks(Nom_du_workbook).Sheets(ID_unique).Cells(59, 6).Value = Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 50).Value


'Picture()
Range("H19").Select 'This is where picture will be inserted
Dim picname As String
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("I19").Left
.Top = Range("I19").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 190#
.ShapeRange.Width = 152#
.ShapeRange.Rotation = 0#
End With

if ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found Exit Sub Range("B20").Select End Sub

'Impression PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Chemin_du_workbook & "\" & Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 3).Value & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=Ouvrir_PDF

'suppression de l'onglet
Application.DisplayAlerts = False
Workbooks(Nom_du_workbook).Sheets(ID_unique).Delete
Application.DisplayAlerts = True

'suppression de la croix
Sheets("Liste LG").Select
Cells(I, 1).Select
Selection.ClearContents
Cells(I, 42).Select
ActiveCell.FormulaR1C1 = "oui"

Message_de_fin = Message_de_fin & vbNewLine & Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 2).Value & " - " & ID_unique
Nombre_de_rapports_a_imprimer = Nombre_de_rapports_a_imprimer + 1
End If
Next I
If Nombre_de_rapports_a_imprimer = 1 Then
esse = "."
Else
esse = "s."
End If

Message_de_fin = Message_de_fin & vbNewLine & "Vous avez imprimé " & Nombre_de_rapports_a_imprimer & " rapport" & esse

'message de fin
Label_message_de_fin:
Workbooks(Nom_du_workbook).Sheets("Liste LG").Select
Application.ScreenUpdating = True
'fin = Timer
'Message_de_fin = Message_de_fin & Chr(10) & "Temps d'exécution : " & (fin - debut) & " s"
MsgBox (Message_de_fin)




End Sub

---------------------------------------------------------------------------------------------
A voir également:

3 réponses

Réponse 1 / 3
tyranausor Messages postés 3545 Date d'inscription jeudi 6 août 2009 Statut Membre Dernière intervention 1 avril 2022 2 033
28 août 2015 à 11:41
Bonjour, une petite question, pour alléger ton code, au lieu de recopier x fois Workbook("Nom_du_workbook").sheets(""Ma_feuille"), pourquoi tu n'utiliserais pas les variables?

pour ton Workbook : Dim Wb as workbook, Ws1 as worksheet, Ws2 as Worksheet

Wb = Workbook.name
Ws1 = Sheets("ID_unique")
Ws2 = Sheets("Liste LG")

ça serait un peu moins long et ça tiendrait dans la fenêtre de l'éditeur qui, elle n'est pas extensible!

Autre chose, utilises au maximum des with pour éviter de réécrire Workbook("...) à chaque fois
0
Réponse 2 / 3
didom
28 août 2015 à 13:06
merci pour ces infos, je vais regarder.
Sinon, pour mon problème d'insertion d'image, avez vous une idée.
0
Réponse 3 / 3
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 729
28 août 2015 à 14:13
Bonjour,

Changer ceci: 

'Picture() 
Range("H19").Select 'This is where picture will be inserted 
Dim picname As String 
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored 
''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
' This resizes the picture 
''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
With Selection 
.Left = Range("I19").Left 
.Top = Range("I19").Top 
.ShapeRange.LockAspectRatio = msoFalse 
.ShapeRange.Height = 190# 
.ShapeRange.Width = 152# 
.ShapeRange.Rotation = 0# 
End With 

if ErrNoPhoto: 
MsgBox "Unable to Find Photo" 'Shows message box if picture not found Exit Sub Range("B20").Select End Sub


par cela: 

Range("H19").Select 'This is where picture will be inserted
Dim picname As String
On Error GoTo err
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("I19").Left
.Top = Range("I19").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 190#
.ShapeRange.Width = 152#
.ShapeRange.Rotation = 0#
End With

fin:

    Exit Sub
    
err:
    'Gestion de l'erreur 76
    If err.Number = 76 Then
        MsgBox "Ce dossier n'existe pas"
    Else
      MsgBox "Unable to Find Photo"
    End If
    
    Resume fin
0
didom
31 août 2015 à 11:36
Bonjour, le message de photo non trouvé est bien mentionné mais en revanche, lorqsqu'il trouve la photo, la macro s'arrête de se générer après l'insertion sans me terminer les actions qu'il restait ensuite ?
0
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 729 > didom
31 août 2015 à 19:48
supprime le :

Exit Sub
0
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 310
Modifié par michel_m le 31/08/2015 à 13:19
Bonjour
erreur de ma part
désolé
0

Discussions similaires

Erreur d'exécution 13 Incompatibilité de type
grace -
pijaku -

5 réponses
ouverture d'un fichier excel à partir d'un code VBA
TraderAS -
pijaku -

3 réponses