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 , j'ai l'impression que c'est la boucle Do Loop qui bug, car quand je change la valeur A6 et que le dossier n'existe pas il ne me crée pas le dossier et le fichier comme le code devrait le faire, il ne fait pas d'erreur il me met une des 2 message box de le boucle, bref je suis dans l'embarras car je pense qu'il ne manque pas grand chose pour que ça tourne au mieux, je te met le code en question que j'ai renommé EditerMuscu

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

Rechercher des sujets similaires à "probleme chemin acces mac 2011"