Macro ne fonctionne pas sur d'autres postes

Bonjour,

J'ai crée un outil pour la logistique exécutant en fin d'utilisation une sauvegarde et une copie du fichier. Sur mon poste tout est ok. Par contre sur les autres postes avec Excel 2007 et 2016, pas d'exécution en fermeture par le bouton quitter. Voici le bout de code:

Option Explicit

Dim wb As Workbook

Private Sub CommandButton1_Click()

Dim mPlage As Range

ThisWorkbook.Application.Visible = True

Set mPlage = ThisWorkbook.Sheets("ETIQUETTE").Range("A1:Z100")

Call EffacePlage(mPlage)

Set mPlage = Nothing

Worksheets("Entree").Select

userform2.Show

End Sub

Private Sub CommandButton2_Click()

ThisWorkbook.Application.Visible = True

Worksheets("Sortie").Select

UserForm3.Show

End Sub

Private Sub CommandButton3_Click()

ThisWorkbook.Application.Visible = True

Worksheets("Entree").Select

UserForm5.Show

End Sub

Private Sub CommandButton4_Click()

ThisWorkbook.Application.Visible = True

Worksheets("Clients").Select

UserForm1.Show

End Sub

Private Sub CommandButton5_Click()

Dim Chemin As String, Fichier As String

Dim reponse As Integer

Application.DisplayAlerts = False

On Error Resume Next

reponse = MsgBox("Avez-vous imprimé vos étiquettes?", vbYesNo + vbQuestion, "Confirmation")

If reponse = vbYes Then

ActiveWorkbook.Save

Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\"

'Ajoute la date du jour et l'heure dans le nom du fichier

Fichier = "Copie_Gestion_In_Out_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")

With ActiveWorkbook

.SaveCopyAs Filename:=Chemin & Fichier & ".xlsm" 'FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

.Save

End With

Shell ("taskkill /F /IM Excel.exe")

'Application.Quit

Else

Exit Sub

End If

Application.DisplayAlerts = True

End Sub

Public Sub EffacePlage(ByRef plage As Range)

plage.ClearContents

End Sub

Private Sub CommandButton6_Click()

Dim Chemin As String, Fichier As String, lettre As String

Dim FSO As Object

Dim Drv As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

With ThisWorkbook.Worksheets("ETIQUETTE")

.Columns(1).Copy

.Columns(6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

.Columns(2).Copy

.Columns(8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

.Columns(1).Clear

.Columns(2).Clear

.Columns(3).Clear

.Columns(4).Clear

.Columns(5).Clear

End With

For Each Drv In FSO.Drives

With Drv

If .IsReady And .DriveType = 1 Then

'MsgBox "Lecteur USB sur : " & .DriveLetter

lettre = Drv.DriveLetter

Chemin = lettre & ":\"

Fichier = "ETIQUETTE"

Sheets("ETIQUETTE").Copy

ActiveWorkbook.SaveCopyAs Filename:=Chemin & Fichier

Set wb = Workbooks.Open(Filename:=Chemin & Fichier & ".xlsm")

With wb

.SaveAs Filename:=Chemin & Fichier & ".xls", FileFormat:=-4143

.Close

End With

Application.DisplayAlerts = False

ActiveWorkbook.Close savechanges:=True

Application.DisplayAlerts = True

Exit Sub

End If

End With

Next Drv

MsgBox "Pas de clé USB détectée. Merci d'en insérer une !"

End Sub

Si quelqu'un a une idée du blocage, je suis preneur.

Merci à vous

Bonjour,

Tu as le bouton </> pour baliser (à coller entre les deux balises "code") ton code plutôt que de le coller tel quel dans le message (plus facile à récupérer pour nous !).

Quand je vois dans ton code la ligne :

Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\"

J'en déduis que vous avez tous le même chemin donc la même racine (lettre du lecteur S:) !

Si ce n'est pas le cas, il faudrait peut être utiliser "FileDialog()" afin que l'utilisateur puisse sélectionner le dossier dans lequel il veut sauvegarder le fichier.

Et ça :

Shell ("taskkill /F /IM Excel.exe")

C'est pas un peu radical comme fermeture (perso, jamais utilisé) ?

Merci de votre réponse. Désolé pour le copier/coller.

J'ai effectivement le même chemin pour la sauvegarde et la copie de sauvegarde (pour info: demande de notre service qualité), à l'exception de la dernière racine.

Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\" pour la copie

Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\" pour la sauvegarde.

La taskill est la solution la plus sûr pour vraiment fermer excel car avec la fonction application.quit ne ferme pas excel.

Si vous avez une autre proposition, ce serait un plus.

Concernant le non fonctionnement sur les différents postes? vous avez une idée?

Bonjour,

Non, je n'ai pas vraiment d'idées, si ça marche pour certains et que vous avez tous le même chemin, je ne vois pas. Vous êtes tous sur PC ou il y en a qui ont des Mac ?

Bonjour,

Non, nous sommes tous sur PC, environnement identique ou bien XP pour certains. Mais l'affaire reste pareil sur l'ensemble des PC.

Re,

Comme j'avais juste survolé ton code, je n'avais pas fait attention au gestionnaire d'erreur, en mode débogage il est impératif de ne pas utiliser On Error Resume Next car sinon les erreurs sont évitées et on ne sais pas ou ça coince. On ne l'utilise que si on est sûr qu'une erreur peut être générée par une action et qu'il va falloir la gérer mais ensuite, on supprime le gestionnaire par On Error GoTo 0 !

Donc, supprime pour l'instant le gestionnaire (On Error Resume Next) et lance le code, tu auras alors ton erreur et tu sauras d'où ça vient !

Merci These.

Je tiens informé dès Lundi.

Bon weekend

Bonjour These,

Le deboggage m'informe de l'erreur suivante :

Private Sub CommandButton5_Click()
Dim Chemin As String, Fichier As String
Dim reponse As Integer

Application.DisplayAlerts = False
'On Error Resume Next
reponse = MsgBox("Avez-vous imprimé vos étiquettes?", vbYesNo + vbQuestion, "Confirmation")
  If reponse = vbYes Then
    ActiveWorkbook.Save
    Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\"
    'Ajoute la date du jour et l'heure dans le nom du fichier
    Fichier = "Copie_Gestion_In_Out_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
    With ActiveWorkbook
    .SaveCopyAs Filename:=Chemin & Fichier & ".xlsm" 'FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       .Save
    End With
    Shell ("taskkill /F /IM Excel.exe")
    'Application.Quit
Else
    Exit Sub
End If
Application.DisplayAlerts = True
End Sub

La ligne .SaveCopyAs Filename:= .... est en jaune

Là je bloque.

Peut-être pourriez-vous m'aider?

Slts

Bonjour ...

un petit essai... remplacer :

.SaveCopyAs Filename:=Chemin & Fichier & ".xlsm" 'FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
 .Save

par

.Save
.SaveAs Chemin & Fichier & ".xlsm",  FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Fred

Sinon autre piste a explorer... si c'est un dossier partager sur un réseau... vérifier avec ton administrateur réseau que les droits NTFS sur le dossier en question sont correctes.... tu peux avoir les droits d’écrire et pas tes collègues.... (ou ton ordi et pas les autres.... on peut faire beaucoup de choses....)

Fred

Bonjour Fred,

Non toujours la même erreur 1004 sur la ligne

        .SaveAs Chemin & Fichier & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Là je cale

Merci Fred,

Je creuse, je vais déplacer le fichier de base vers le serveur commun dont les droits sont open pour tous.

Je profite également de ce mesage pour vous remercier tous. Je vous tiens informé.

Slts

alors pour faire un autre essai

remplace :

 Chemin = "S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\"

par

Chemin = Environ("USERPROFILE") & "\Desktop\"

ce qui permet de faire un enregistrement sur le bureau local de l'utilisateur...

si cela fonctionne c'est que c'est un problème réseau... et que le chemin d'accès au dossier S:\BE\PRODUCTION\SAMARA\CODEBARRE\SAUVEGARDE\ n'est pas accessible dans ce cas difficile d'aider en n’étant pas devant l'ordi.....

Fred

A tous,

Problème résolu avec droit d'écriture administratif.

Super

Merci beaucoup de votre aide encore une fois.

Re

Tant mieux....

Fred

Bonjour à tous,

Après avoir résolu le PB d'écriture de fichier sur le serveur et ce grâce à votre aide, je vous sollicite de nouveau car j'ai une incompréhension de le message visant la ligne " Set wb = Workbooks.Open(Filename:=Chemin & "ETIQUETTE.xlsm")"

Private Sub CommandButton6_Click()
Dim Chemin As String, Fichier As String, lettre As String
Dim wb As Workbook
Dim FSO As Object
    Dim Drv As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With ThisWorkbook.Worksheets("ETIQUETTE")
                    .Columns(1).Copy
                    .Columns(6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Columns(2).Copy
                    .Columns(8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Columns(1).Clear
                    .Columns(2).Clear
                    .Columns(3).Clear
                    .Columns(4).Clear
                    .Columns(5).Clear
    End With

    For Each Drv In FSO.Drives
        With Drv
            If .IsReady And .DriveType = 1 Then
                'MsgBox "Lecteur USB sur : " & .DriveLetter
                lettre = Drv.DriveLetter
                Chemin = lettre & ":\"
                Fichier = "ETIQUETTE"
                ThisWorkbook.Worksheets("ETIQUETTE").Copy 'Sheets("ETIQUETTE").Copy
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveCopyAs Filename:=Chemin & Fichier & ".xls", FileFormat:=-4143, CreateBackup:=False ' Filename:=Chemin & Fichier & ".xlsm"
                ActiveWorkbook.Close
                Set wb = Workbooks.Open(Filename:=Chemin & "ETIQUETTE.xlsm")
                With wb
                   .SaveAs Filename:=Chemin & Fichier & ".xls", FileFormat:=-4143, CreateBackup:=False
                   .Close
               End With

                ActiveWorkbook.Close savechanges:=True
                Application.DisplayAlerts = True
                Exit Sub
            End If
        End With
    Next Drv
    MsgBox "Pas de clé USB détectée. Merci d'en insérer une !"

End Sub

Quelqu'un aurait-il une idée du blocage.

Merci de votre aide