Problème chemin d'accès Excel Mac 2011
Bonjour le forum, comment allez-vous?
Content de vous rejoindre sur ce forum,
étant débutant sur excel j'avais commencé à coder sur PC et j'avais pris de bonnes habitudes. Pour mon nouvel emploi, toute l'entreprise tourne sous MAC, j'ai pu commencer à me familiariser avec le codage VBA mais je bloque sur mes chemins d'accès que j'avais programmé sous PC.
Je vous envoi une partie de code qui bug. Tout d'abord l'utilisation Dir est tout le temps surligner dans l'erreur ! et quand j'enlève Dir Mkdir pour passer directement par Application.Workbooks. Open j'ai un nouveau message d'erreur 68 comme quoi le chemin d'accès (qui est correct) est introuvable.
Sub OuvrirMuscu()
'CREER UN DOSSIER
s = Feuil4.[A1]
r = Feuil23.[c2]
If Dir("Macintosh HD:Utilisateurs:" & s & ":Dropbox:joueurs:" & r, (vbDirectory) = "" Then _
MkDir "Macintosh HD:Utilisateurs:" & s & ":Dropbox:joueurs:" & r
' CREER UN CLASSEUR
Application.ScreenUpdating = False
xnomfic = Range("C2"): ficd = xnomfic & " Musculation.xlsx"
' Contrôle de l'existence du fichier ou classeur
If FichierExiste("Macintosh HD:Utilisateurs:" & s & ":Dropbox:joueurs:" & r & ":" & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
'ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Application.Workbooks.Open("Macintosh HD:Utilisateurs:" & s & ":Dropbox:joueurs:" & r & ":" & ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
Sheets(Sheets.Count).Select
Range("A1").Select
ActiveWindow.Zoom = 100
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
End If
End Sub
Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
Je vous avoue vraiment bloquer malgré des recherches sur votre forum ainsi que l'ensemble du net sachant que sur PC le code marche super bien
Je vous remercie du temps que vous m'accorderez
Cordialement
Julien
Bonjour
Le fichier contenant le code se trouve dans le meme répertoire ?
Crdlt
Bonjour Dan,
Merci de ta réponse rapide
Non le fichier est dans un autre répertoire mais il n'y a pas de roblème pour le mettre dans le même j'ai d'ailleurs essayé avec thisworbook.path mais j'ai une erreur de prépiphérique non disponible
Sub OuvrirMuscu()
'CREER UN DOSSIER
s = Feuil4.[A1]
r = Feuil23.[c2]
If Dir(ThisWorkbook.Path & ":" & r & Application.PathSeparator, vbNormal) = "" Then _
MkDir ThisWorkbook.Path & ":" & r & Application.PathSeparator
' CREER UN CLASSEUR
Application.ScreenUpdating = False
xnomfic = Range("C2"): ficd = xnomfic & " Musculation.xlsx"
' Contrôle de l'existence du fichier ou classeur
If FichierExiste(ThisWorkbook.Path & r & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
'ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Application.Workbooks.Open(ThisWorkbook.Path & ":" & r & ":" & ficd & Application.PathSeparator).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
Sheets(Sheets.Count).Select
Range("A1").Select
ActiveWindow.Zoom = 100
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
End If
End Sub
Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
Voici ma dernière tentative avec comme erreur 68 périphérique non disponible et surligné la fonction fichierexiste(ficd)
Je t'avoue ne pas tout comprendre
cordialement
Julien
Re
Il faudrait savoir ce que c'est r et s. Probablement un nom de fichier mais lequel et quelle est l'extension
Puis si je comprends bien,tu cherches à savoir si un fichier existe ou non dans le répertoire dropbox ?
Ce serait bien d'avoir un complément d'explication sur tout ce qui est recherché
Possible de voir ce fichier ?
Crdlt
Bonjour Dan,
Merci de l'attention que tu portes à ce dossier, le "s" est la variable du nom d'utilisateur (Macro placée dans this workbook),et le "r" le nom de la personne à qui on édite une feuille afin d'avoir un dossier personnalisé, je vais t'envoyer le fichier dépersonnalisé.
L'adaptation vba sur Mac est un petit casse tête
Cordialement
Julien
Re
L'adaptation vba sur Mac est un petit casse tête
Non mais ce qui est pas évident c'est qu'il va falloir analyser les codes....
Merci du fichier dans lequel j'ai du créé la feuil4. Elle correspond au nom de l'utilisateur du fichier ?
A quoi sert les deux points dans cette instruction --> Client = ":" & Range("C2")
C'est pour le MAC je suppose ?
Dans les instructions qui suivent, elle servent a controler que le dossier Joueur existe bien ?
crdlt
Re Dan, le forum,
C'est tout fait ça pour les fonctions, désolé j'ai supprimé un peu trop de feuille.
C'est surtout sur la fonction que ça bug pas mal
Cordialement
Julien
Bonjour Dan, le forum,
Comment allez vous?
Voilà j'ai bien avancé sur le code en question je l'ai adapté pour mac et PC, cependant j'ai un petit problème , le code Mac n'est pas très stable, c'est à dire qu'il va bien marcher un moment et puis il va pas faire ce que je lui demande
Option Explicit
Dim Mess As Integer, r, chemin As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim xshcherchee As Worksheet
Dim Legraph As ChartObject
Dim MyName, Exist As Object
Dim Joueur As String
Sub EditerMuscu()
#If Mac Then
On Error Resume Next
Exist = 0
Joueur = ":" & Range("A6")
chemin = ActiveWorkbook.Path
ChDir chemin & Joueur & ficd
MyName = Dir(chemin & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx"
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
Do While MyName <> "" ' Commence la boucle.
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Joueur & MyName) _
And vbDirectory) = vbDirectory Then
Exist = 1
Application.Workbooks.Open (chemin & Joueur & ficd)
ActiveWindow.DisplayGridlines = False
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1048576").End(xlUp)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le dernier programme a bien été edité !"
Exit Sub
End With
End If
Next
' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh)
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("1:100").RowHeight = 16
.Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Une nouvelle semaine commence !"
Exit Sub
End With
Exit Do
End If
End If
'MyName = Dir ' Extrait l'entrée suivante.
Loop
If Exist = 0 Then
MkDir chemin & Joueur
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets("Feuil1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("1:100").RowHeight = 16
.Application.CutCopyMode = False
End With
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
'Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=chemin & Joueur & ficd 'MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Close
End If
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le Dossier " & r & " a bien été créé."
'ActiveWindow.SelectedSheets.PrintOut from:=1, To:=1, copies:=1, collate:=0
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
#Else
'CREER UN DOSSIER
'Exist = 0
Joueur = "\" & Range("A6")
'ChDir ThisWorkbook.Path & Joueur & ficd
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx"
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
If MyName = "" Then _
MkDir ThisWorkbook.Path & Joueur
' CREER UN CLASSEUR dans le dossier
' Contrôle de l'existence du fichier ou classeur
If FichierExiste(ThisWorkbook.Path & Joueur & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
Workbooks.Open (ThisWorkbook.Path & Joueur & ficd), UpdateLinks:=0 ': Workbooks(ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWindow.DisplayGridlines = False
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1048576").End(xlUp)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le dernier programme a bien été edité !"
Exit Sub
End With
End If
Next
' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 14.25
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Une nouvelle semaine commence !"
Exit Sub
End With
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveWindow.DisplayGridlines = False
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "Sauvegarde " & r & " effectuée."
' ------------------------------------------------------------------------------------------------------------------
Else
'___________________________________________________________________________________________________________________
' Création du fichier ou classeur et copie de la feuille modele
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets("Feuil1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 20
.Application.CutCopyMode = False
End With
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Joueur & ficd ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Close
MsgBox "Le Dossier " & r & " a bien été créé."
End If
'ActiveWindow.SelectedSheets.PrintOut from:=1, To:=1, copies:=1, collate:=0
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
#End If
End Sub
Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
C'est la partie surlignée qui bugue le partie PC fonctionne super bien et la fonction est pour la partie PC
En te remerciant par avance de te pencher sur le sujet
Cordialement
Julien
Re
Déso pour mon retour tardif mais j'étais à l'étranger
Waouh pour le code... j'essaie de voir dans ton premier fichier pour te mettre les instructions Mac et PC mais pas simple de comprendre comment tu fonctionnes
Attention que si tu travailles de ton coté et moi du mien on va pas y arriver. Le code qui est posté doit se placer dans quel module ?
Que fais-tu dans la ligne code "Extrait la première entrée" ?
Au début du code, on est sur la feuille Modèle car dans Range("A6") on a aucune donnée
Sinon, mets les balises de code. Pour bien les utiliser, colle le code dans ton post puis sélectionne le en entier. Ensuite clique sur le bouton vert CODE
Crdlt
Bonjour Dan, le forum,
oui c'est vrai que j'essaye pas mal de choses en attendant mais n'étant pas un expert ça marche pas toujours
Je pensais pourtant avoir utilisé la fonction code. sur le fil de discussion cela s'affiche correctement de mon côté.
Je t'envoi le fichier en pièce jointe, il s'agit du module 5 le code "Editermuscu" et le module 3 le code "Enregistrernutrition". Je souhaiterai que les fichiers créés de la part de ces 2 codes aillent de façon organisée comme dans le code, dans le même dossier nommé range A6 (feuillemodèle) ou A3 (feuil alimentaire). sachante que je vais mettre en place d'autres trames pour créer d'autres fichiers tel que le feuille Test. j'espère que j'ai été assez clair car c'est pas très facile à mettre par écrit.
Je voudrai t'envoyer le fichier mais celui ci est trop lourd pour le joindre sir le forum y'a t-il un autre moyen de te le transmettre ?
Cordialement
Julien
Bonjour Dan,
Je te remercie encore du temps que tu passes sur ce code, je suis vraiment un novice, je batis mes macros en prenant des bouts de codes sur internet et puis je les adapte.
Je t'envoi ce code directement sur cette page celui ci est à mettre dans le module 5 à la place de EditerMuscu sur le document que je t'avais envoyé
Qu'en penses tu?
Option Explicit
Dim Mess As Integer, r, chemin As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim xshcherchee As Worksheet
Dim Legraph As ChartObject
Dim MyName, Exist As Object
Dim Joueur As StringSub EditerMuscu()
Dim MyName, Exist As Object
Dim Joueur As String
#If Mac Then
'Dim MyName, Exist, mWord As Object
On Error Resume Next
'Set mWord = GetObject(, "Word.Application")
'If Err Then
'Set mWord = CreateObject("Word.Application")
'End If
'mWord.DisplayAlerts = False
Exist = 0
Joueur = ":" & Range("A6")
ChDir ThisWorkbook.Path & Joueur & ficd
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx"
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
Do While MyName <> "" ' Commence la boucle.
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Joueur & MyName) _
And vbDirectory) = vbDirectory Then
Exist = 1
Application.Workbooks.Open (ThisWorkbook.Path & Joueur & ficd)
ActiveWindow.DisplayGridlines = False
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1048576").End(xlUp)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le dernier programme a bien été edité !"
Exit Sub
End With
End If
Next
' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 14.25
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Une nouvelle semaine commence !"
Exit Sub
End With
'ActiveWindow.DisplayHeadings = False
'Application.DisplayFullScreen = True
'Application.CutCopyMode = False
'ActiveWindow.DisplayZeros = False
'ActiveWindow.DisplayGridlines = False
'ActiveWorkbook.Save
'ActiveWorkbook.Close
'MsgBox "Sauvegarde " & r & " effectuée."
Exit Do
End If
End If
'MyName = Dir ' Extrait l'entrée suivante.
Loop
If Exist = 0 Then
MkDir ThisWorkbook.Path & Joueur
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets("Feuil1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 20
.Application.CutCopyMode = False
End With
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
'Application.DisplayFullScreen = True
'Application.CutCopyMode = False
' ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Joueur & ficd ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
End If
ActiveWorkbook.Close
MsgBox "Le Dossier " & r & " a bien été créé."
'ActiveWindow.SelectedSheets.PrintOut from:=1, To:=1, copies:=1, collate:=0
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
#Else
'CREER UN DOSSIER
'Exist = 0
Joueur = "\" & Range("A6")
'ChDir ThisWorkbook.Path & Joueur & ficd
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx"
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
If MyName = "" Then _
MkDir ThisWorkbook.Path & Joueur
' CREER UN CLASSEUR dans le dossier
' Contrôle de l'existence du fichier ou classeur
If FichierExiste(ThisWorkbook.Path & Joueur & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
Workbooks.Open (ThisWorkbook.Path & Joueur & ficd), UpdateLinks:=0 ': Workbooks(ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWindow.DisplayGridlines = False
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1048576").End(xlUp)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le dernier programme a bien été edité !"
Exit Sub
End With
End If
Next
' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 14.25
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Une nouvelle semaine commence !"
Exit Sub
End With
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveWindow.DisplayGridlines = False
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "Sauvegarde " & r & " effectuée."
' ------------------------------------------------------------------------------------------------------------------
Else
'___________________________________________________________________________________________________________________
' Création du fichier ou classeur et copie de la feuille modele
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S64").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets("Feuil1")
.Range("A1:S64").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S64").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 20
.Application.CutCopyMode = False
End With
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Joueur & ficd ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Close
MsgBox "Le Dossier " & r & " a bien été créé."
End If
End If
'ActiveWindow.SelectedSheets.PrintOut from:=1, To:=1, copies:=1, collate:=0
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
#End If
End Sub
Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
La partie surligner est la partie la plus "stable" mais j'ai encore des bug, je me sers de la partie PC pour regarder d'où les erreurs peuvent venir mais je n'arrive pas à les identifier.
Cordialement
Julien
re
As-tu avancé sur le sujet ou éventuellement résolu le problème
Cordialement
Bonjour Dan , le forum,
Oui j'ai pu avancer sur mon code, cependant je bloque sur une bêtise, tout simplement copier l'onglet "Modele" et la coller dans le classeur que j'ouvre via la macro EditerMuscu. j'ai essayé avec
Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:= Workbooks(ficd).Sheets(Sheets.Count).Paste
je n'ai pas d'rreur qui s'affiche
Bref je n'y arrive pas le Copy after n'est pas pris en compte et je ne comprend pas!
Si tu peux m'aider sur ce point ça me permettrai de finaliser mon projet VBA
Cordialement
Julien
Re,
Sans verifier, enleve le PASTE dans l'instruction
Une fois termine, je peux regarder pour le code sous Mac
Cordialement
Re Dan,
Voici le code pour Mac surligné. Si j'enlève On error resume Next les fonctions dir ne sont pas reconnues.
J'ai trouvé la fonction sur internet. Et enfin même en ayant enlevé Paste pour copier l'onglet ça en marche pas, j'ai l'impression que le Copy After n'est pas pris en compte
Sub EditerMuscu()
Dim MyName, Exist As Object
Dim Joueur As String
#If Mac Then
On Error Resume Next
Application.ScreenUpdating = False
Joueur = ":" & Range("A6")
'ChDir ThisWorkbook.Path & Joueur
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = ":" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
nbfeuille = Sheets.Count
If Dir(ThisWorkbook & Joueur, vbDirectory) = "" Then _
MkDir ThisWorkbook.Path & Joueur
If FileOrFolderExistsOnMac(ThisWorkbook.Path & Joueur & ficd) = True Then
Workbooks.Open (ThisWorkbook.Path & Joueur & ficd), UpdateLinks:=0 ': Workbooks(ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:=Workbooks(ficd).Sheets(Sheets.Count)
ActiveWorkbook.Save: ActiveWorkbook.Close
Else
Workbooks.Add
'Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:=Workbooks(ficd).Sheets(xlLast)
Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:=Workbooks(ficd).Sheets(Sheets.Count)
' Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 15", "Picture 13", "Picture 2")).Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
'Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Joueur & ficd ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
End If
ActiveWorkbook.Close
MsgBox "Le Dossier " & r & " a bien été créé."
Application.ScreenUpdating = True
#Else
'CREER UN DOSSIER
'Exist = 0
Joueur = "\" & Range("A6")
'ChDir ThisWorkbook.Path & Joueur & ficd
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory) ' Extrait la première entrée.
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx"
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
Application.ScreenUpdating = False
xnomfic = Range("A6"): ficd = "\" & xnomfic & " Musculation.xlsx": xcell = Range("D2"): xnomsh = Replace(xcell, "/", "")
r = Feuil23.[A6]
If Dir(ThisWorkbook & Joueur, vbDirectory) = "" Then _
MkDir ThisWorkbook.Path & Joueur
' CREER UN CLASSEUR dans le dossier
' Contrôle de l'existence du fichier ou classeur
If FichierExiste(ThisWorkbook.Path & Joueur & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
Workbooks.Open (ThisWorkbook.Path & Joueur & ficd), UpdateLinks:=0 ': Workbooks(ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWindow.DisplayGridlines = False
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S69").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1048576").End(xlUp)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Application.CutCopyMode = False
Application.DisplayAlerts = False
'For Each Legraph In ActiveSheet.ChartObjects
' Legraph.Delete
' Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Le dernier programme a bien été edité !"
Exit Sub
End With
End If
Next
' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S69").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets(xnomsh).Range("A1")
.Range("A1:S69").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S69").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S69").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 14.25
.Application.CutCopyMode = False
Application.DisplayAlerts = False
For Each Legraph In ActiveSheet.ChartObjects
Legraph.Delete
Next
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
MsgBox "Une nouvelle semaine commence !"
Exit Sub
End With
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveWindow.DisplayGridlines = False
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "Sauvegarde " & r & " effectuée."
' ------------------------------------------------------------------------------------------------------------------
Else
'___________________________________________________________________________________________________________________
' Création du fichier ou classeur et copie de la feuille modele
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A1:S69").Copy
'Workbooks("Musculation.xlsm").Sheets("Modele").Shapes.Range(Array("Picture 17", "Picture 19", "Picture 9", "Picture 10", "Picture 11", "Picture 12", "Picture 13", "Picture 14", "Picture 15", "Picture 16")).Select
With ActiveWorkbook.Sheets("Feuil1")
.Range("A1:S69").PasteSpecial Paste:=xlPasteFormats
.Range("A1:S69").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A1:S69").PasteSpecial Paste:=xlPasteColumnWidths
.Rows("4:34").RowHeight = 20
.Application.CutCopyMode = False
End With
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Application.DisplayFullScreen = True
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Joueur & ficd ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Close
MsgBox "Le Dossier " & r & " a bien été créé."
End If
End If
'ActiveWindow.SelectedSheets.PrintOut from:=1, To:=1, copies:=1, collate:=0
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
#End If
End Sub
Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
Function FileOrFolderExistsOnMac(FileOrFolderstr As String) As Boolean
'Ron de Bruin : 26-June-2015
'Function to test whether a file or folder exist on a Mac in office 2011 and up
'Uses AppleScript to avoid the problem with long names in Office 2011,
'limit is max 32 characters including the extension in 2011.
Dim ScriptToCheckFileFolder As String
Dim TestStr As String
If Val(Application.Version) < 15 Then
ScriptToCheckFileFolder = "tell application " & Chr(34) & "System Events" & Chr(34) & _
"to return exists disk item (" & Chr(34) & FileOrFolderstr & Chr(34) & " as string)"
FileOrFolderExistsOnMac = MacScript(ScriptToCheckFileFolder)
Else
On Error Resume Next
MyName = Dir(ThisWorkbook.Path & Joueur & ficd, vbDirectory)
On Error GoTo 0
If Not MyName = vbNullString Then FileOrFolderExistsOnMac = True
End If
End Function
Merci pour ton aide
confirme moi si le code est bien présenté stp
Cordialement
Julien
re
Et enfin même en ayant enlevé Paste pour copier l'onglet ça en marche pas, j'ai l'impression que le Copy After n'est pas pris en compte
Dans cette ligne, le nom ficd inclut bien l'extension du fichier ? xlsx ou xlsm ??
Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:=Workbooks(ficd).Sheets(Sheets.Count)
Si ce n'est pas le cas, essaie comme ceci
Workbooks("Musculation.xlsm").Sheets("Modele").Copy After:=Workbooks(ficd & "xlsx").Sheets(Sheets.Count)
Il faut aussi que les deux fichiers soient ouverts évidemment
Cordialement
Bonjour Dan, la forum,
désolé de la réponse tardive et merci pour tes conseils, le code est bien finalisé et tourne sur Mac et PC depuis hier. et le copy after de la feuille fonctionne aussi, donc un grand merci. je vais cliquer sur RESOLU
bonne journée
à bientôt
Julien
Bonjour Dan, la forum,
désolé de la réponse tardive et merci pour tes conseils, le code est bien finalisé et tourne sur Mac et PC depuis hier. et le copy after de la feuille fonctionne aussi, donc un grand merci. je vais cliquer sur RESOLU
bonne journée
à bientôt
Julien
re
Ok. J'aurais pas fait le code comme cela mais si cela fonctionne tant mieux
Pour le RESOLU, cela n'existe pas ici.
Pour clôturer un fil, clique sur la case à cocher Verte à coté du bouton EDITER. La case devient rouge.
Pour réouvrir le fil, clique sur la case devenu rouge.
Cordialement
Re,
ok , pour le code j'ai l'impression qu'il y a plusieurs façon de faire mais je t'avoue je suis pas très expert. je suis toujours très curieux de voir les autres façon de faire donc si tu as une idée je suis preneur aussi sans que cela te fasse perdre ton temps bien sur.
bonne journée à toi et merci encore,
Cordialement
Julien