Macro à corriger

bonjour ,

cette macro permet d'enregistré un fichier vers un répertoire et le renomme en fonction des données d'une cellule (F17) , elle permet également de renommer les 3 images.jpg contenue dans le répertoire avec les données de la cellule (F17)

lorsque je clic sur mon bouton (avec cette macro affectée) tout se passe bien si dans mon répertoire il y a les 3 images.JPG

( 1.JPG/2.JPG/3.JPG )

le problème est que parfois dans mon répertoire il y a que les images ( 1.JPG et 3.JPG ) , lorsque je clic sur mon bouton , seulement l'image 1.JPG se renomme , mon document ne s'enregistre plus et l'image 3.JPG reste inchangée

besoin d'aide pour revoir cette macro qui m'est très utile , merci

Sub Doc_&_Photos()

Dim AncienNom As String, NouveauNom As String

AncienNom = "C:\Users\groupe\Desktop\test\1.JPG" ' chemin répertoire cible"

NouveauNom = "C:\Users\fabien\Desktop\test\" & Range("F17") & " " & Format(Date, "ddMMyyyy") & " photo 1.JPG"

'Vérifie si le fichier à renommer existe.

If Dir(AncienNom) = "" Then Exit Sub

'Renomme le fichier

Name AncienNom As NouveauNom

AncienNom = "C:\Users\groupe\Desktop\test\2.JPG" ' chemin répertoire cible"

NouveauNom = "C:\Users\groupe\Desktop\test\" & Range("F17") & " " & Format(Date, "ddMMyyyy") & " photo 2.JPG"

'Vérifie si le fichier à renommer existe.

If Dir(AncienNom) = "" Then Exit Sub

'Renomme le fichier

Name AncienNom As NouveauNom

AncienNom = "C:\Users\groupe\Desktop\test\3.JPG" ' chemin répertoire cible

NouveauNom = "C:\Users\groupe\Desktop\test\" & Range("F17") & " " & Format(Date, "ddMMyyyy") & " TRX.JPG"

'Vérifie si le fichier à renommer existe.

If Dir(AncienNom) = "" Then Exit Sub

'Renomme le fichier

Name AncienNom As NouveauNom

Dim ENDROIT As String, Nom_De_Fichier As String

N1 = Range("F17").Text ' le contenu de la cellule F17

If N1 = "" Then Exit Sub

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = "C:\Users\groupe\Desktop\test\" ' ( <= choix du chemin .InitialFileName = "EXEMPLE"\Users\groupe\Desktop\test\" )

If .Show = -1 Then

ENDROIT = .SelectedItems(1) & "\"

On Error GoTo 100 'Resume Next

Application.ScreenUpdating = False

Application.DisplayAlerts = False

ThisWorkbook.ActiveSheet.Copy

Nom_De_Fichier = N1 & " " & Format(Date, "ddMMyyyy") & " DOC.xlsx"

With ActiveWorkbook

.ActiveSheet.DrawingObjects.Delete

.SaveAs Filename:=ENDROIT & Nom_De_Fichier

.Close

End With

Else

End If

End With

Application.ScreenUpdating = True

Application.DisplayAlerts = True

Exit Sub

100

End Sub

Bonjour

je n'ai pas regardé le code en entier mais ton problème se situ ici (pour l'exemple donné)

AncienNom = "C:\Users\groupe\Desktop\test\2.JPG" ' chemin répertoire cible"
NouveauNom = "C:\Users\groupe\Desktop\test\" & Range("F17") & " " & Format(Date, "ddMMyyyy") & " photo 2.JPG" 

'Vérifie si le fichier à renommer existe.
If Dir(AncienNom) = "" Then Exit Sub

LA ligne surlignée vérifie si le fichier a renommer existe si c'est pas le cas tu quit la Sub (Exit Sub) et donc le reste du code ne s’exécute pas

je te conseil de faire comme ceci :

AncienNom = "C:\Users\groupe\Desktop\test\2.JPG" ' chemin répertoire cible"
NouveauNom = "C:\Users\groupe\Desktop\test\" & Range("F17") & " " & Format(Date, "ddMMyyyy") & " photo 2.JPG" 

'Vérifie si le fichier à renommer existe.
If Dir(AncienNom) <> "" Then 
code qui permet de renommer le fichier
end if 

et faire cela partout

fred

Bonjour Fred,

Merci ça fonctionne !

problème résolu !