Macro générant des raccourcis de fichiers
gilles72
Messages postés
34
Statut
Membre
-
pijaku Messages postés 13513 Date d'inscription Statut Modérateur Dernière intervention -
pijaku Messages postés 13513 Date d'inscription Statut Modérateur Dernière intervention -
Bonjour,
j'ai une macro dans EXCEL 2007 qui va dans divers repertoires et sous repertoires, chercher des fichiers et en faire une copie dans un endroit donné.
J'aimerais remplacer les copies de fichiers par un raccourci de chacun de ces fichiers.
KEKUN aurait-y connaissance d'un code qui permettrait de faire ça ?
Merci a ceusses qui ont le savoir et le font partager!
Gilles72
j'ai une macro dans EXCEL 2007 qui va dans divers repertoires et sous repertoires, chercher des fichiers et en faire une copie dans un endroit donné.
J'aimerais remplacer les copies de fichiers par un raccourci de chacun de ces fichiers.
KEKUN aurait-y connaissance d'un code qui permettrait de faire ça ?
Merci a ceusses qui ont le savoir et le font partager!
Gilles72
A voir également:
- Macro générant des raccourcis de fichiers
- Renommer des fichiers en masse - Guide
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Fichiers epub - Guide
- Gestionnaire de fichiers - Télécharger - Gestion de fichiers
- Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
3 réponses
Bonjour,
Peut être pourrais tu nous copier le code de ta macro d'origine? Avec cela nous serions à même de la modifier.
Peut être pourrais tu nous copier le code de ta macro d'origine? Avec cela nous serions à même de la modifier.
bonjour Pijaku,
excuses du retard et merci de ta suggestion
ci dessous le code en question:
Sub insère_fichiers_affaires()
'macro qui :
'à partir de l'onglet affaire effectue les opération de copie ou de création
' de répertoire pour mettre en place dans le répertoire d'affaire crée les fichiers aux endroits précisés
Dim filesysobj As Object
Dim Racine As Object
Dim ledossierNMoinsUn As Object
Dim RepSource, RepDest, FicSource, FicDest, NoDevis, NoAff, NomAffaire, Action As String
Dim R As Integer
Dim Msg, Style, Title, Response, verifaction
Set filesysobj = CreateObject("Scripting.FileSystemObject")
Set Racine = filesysobj.GetFolder(ThisWorkbook.Path)
Set ledossierNMoinsUn = Racine.ParentFolder
Sheets("Fiche").Select
verifaction = Cells(2, 3).Value ' cellule C2
If verifaction <> "" Then
Msg = "Cette opération va réinitialiser les données des fichiers déjà en place. Continuer ?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Alerte écrasement" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' User chose no : exit sub.
Exit Sub
End If
End If
NoDevis = Cells(12, 3).Value
NoAff = Cells(12, 2).Value
NomAffaire = Cells(8, 2).Value
Sheets("Affaire").Select
'effacer la colonne F de résultat d'éxécution de la macro
Range("F2:F1000").Select
Selection.ClearContents
' en cas d'erreur on reporte l'erreur dans la case col "F" ligne n° R
On Error GoTo TraiteErr
For R = 2 To 50
Action = Cells(R, 1).Value
' Action = UCase(Action) 'on convertit en majuscule
RepSource = Cells(R, 2).Value
FicSource = Cells(R, 3).Value
RepDest = Cells(R, 4).Value
FicDest = Cells(R, 5).Value
If Action = "COPIE" Then
Cells(R, 6).Value = "Copie OK" ' on le met avant car si pb sera écrasé
FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If
If Action = "CREREP" Then
Cells(R, 6).Value = "CreRep OK" ' on le met avant car si pb sera écrasé
MkDir Racine & "\" & RepDest
End If
If Action = "CRERAC" Then ' on copie le raccourci vers le fichier
Cells(R, 6).Value = "Raccourci OK" ' on le met avant car si pb sera écrasé
'' FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If
Next R
Sheets("Fiche").Select
Cells(2, 3).Value = "affaire copié" ' en ligne 2 colonne 3 (C2)
Exit Sub
MERCI de ton aide
Gilles 72
excuses du retard et merci de ta suggestion
ci dessous le code en question:
Sub insère_fichiers_affaires()
'macro qui :
'à partir de l'onglet affaire effectue les opération de copie ou de création
' de répertoire pour mettre en place dans le répertoire d'affaire crée les fichiers aux endroits précisés
Dim filesysobj As Object
Dim Racine As Object
Dim ledossierNMoinsUn As Object
Dim RepSource, RepDest, FicSource, FicDest, NoDevis, NoAff, NomAffaire, Action As String
Dim R As Integer
Dim Msg, Style, Title, Response, verifaction
Set filesysobj = CreateObject("Scripting.FileSystemObject")
Set Racine = filesysobj.GetFolder(ThisWorkbook.Path)
Set ledossierNMoinsUn = Racine.ParentFolder
Sheets("Fiche").Select
verifaction = Cells(2, 3).Value ' cellule C2
If verifaction <> "" Then
Msg = "Cette opération va réinitialiser les données des fichiers déjà en place. Continuer ?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Alerte écrasement" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' User chose no : exit sub.
Exit Sub
End If
End If
NoDevis = Cells(12, 3).Value
NoAff = Cells(12, 2).Value
NomAffaire = Cells(8, 2).Value
Sheets("Affaire").Select
'effacer la colonne F de résultat d'éxécution de la macro
Range("F2:F1000").Select
Selection.ClearContents
' en cas d'erreur on reporte l'erreur dans la case col "F" ligne n° R
On Error GoTo TraiteErr
For R = 2 To 50
Action = Cells(R, 1).Value
' Action = UCase(Action) 'on convertit en majuscule
RepSource = Cells(R, 2).Value
FicSource = Cells(R, 3).Value
RepDest = Cells(R, 4).Value
FicDest = Cells(R, 5).Value
If Action = "COPIE" Then
Cells(R, 6).Value = "Copie OK" ' on le met avant car si pb sera écrasé
FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If
If Action = "CREREP" Then
Cells(R, 6).Value = "CreRep OK" ' on le met avant car si pb sera écrasé
MkDir Racine & "\" & RepDest
End If
If Action = "CRERAC" Then ' on copie le raccourci vers le fichier
Cells(R, 6).Value = "Raccourci OK" ' on le met avant car si pb sera écrasé
'' FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document)
End If
Next R
Sheets("Fiche").Select
Cells(2, 3).Value = "affaire copié" ' en ligne 2 colonne 3 (C2)
Exit Sub
MERCI de ton aide
Gilles 72
Alors essaye de voir dans cette piste :
remplacer :
par :
A adapter bien entendu
remplacer :
If Action = "CRERAC" Then ' on copie le raccourci vers le fichier Cells(R, 6).Value = "Raccourci OK" ' on le met avant car si pb sera écrasé '' FileCopy RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest '(supprime non affaire sur document) End If
par :
Dim adresse as String If Action = "CRERAC" Then ' on copie le raccourci vers le fichier Cells(R, 6).Select ' on le met avant car si pb sera écrasé adresse = RepSource & "\" & FicSource, Racine & "\" & RepDest & "\" & NoAff & "-" & FicDest ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=adresse End If
A adapter bien entendu
Bonjour Pijaku,
après adaptation, ça fonctionne, mais ça place les raccourcis dans la feuille XL et non dans les repertoires créés
En fait, j'aimerais que dans ces repertoires qu'on crée, viennent se placer des raccourcis, pointant vers les fichiers d'origine, et non des copies de ces fichiers d'origine
merci
cordialement
gilles72
après adaptation, ça fonctionne, mais ça place les raccourcis dans la feuille XL et non dans les repertoires créés
En fait, j'aimerais que dans ces repertoires qu'on crée, viennent se placer des raccourcis, pointant vers les fichiers d'origine, et non des copies de ces fichiers d'origine
merci
cordialement
gilles72
