VBA Publications Macro vers 2280 Excels
Bonjour à tous, depuis plusieurs semaine je touche à une solutions pour problème que mon entre prise me pose.
Je vais vous parlez des étapes que j'ai effectué / des méthodes utiliser ainsi que des hypothèses quant au problème.
Sujet :
- Créer une macro utile pour le personnel, puis la déployer sur tout les Excel utilisé par le personnel
- Pouvoir la mettre à jours et la redéployer efficacement.
Complexité :
- Tout les Excel n'ont pas la même version
- Certains ne sont pas en .xlsm
- Certains on des MDP
- Certains sont partagé
- Il y en à 2280
- On est sur un serveur (Réseau partagé)
- Ma macro utilise des compléments
- Ma macro est dans la feuille (Pas de module)
(Et plein d'autre)
Solutions :
• Pour les extension qui différent la solutions à était de faire un script powershell qui boucle des dossiers / fichier et convertit les fichiers avec la bonne extension.
✔️
• Pour les MDP pas de soucis, je gère le dévérouillage / revérouillage des feuilles.
✔️
• Pour le partage, un soucis pour plus tard. Pour le moment je désactive puis réactive mais je ne remet pas les anciens paramètre du partage donc "on verra"
✔️
• Il y en à 2280 (Petit travail du week'end pour faire bosser une macros)
✔️
• Le serveur le soucis, ça peut être le multi-editing d'où la solution de le faire un week'end quand personne ne bosse dessus
✔️
• Pour les compléments j'ai rebosser la macros maintenant j'ai juste un bout de code dans "ThisWorkbooks" et 2 Userform à envoyer et plus aucun complément.
✔️
• Pour les versions pour le moment, je n'ai pas encore était confronter au problème mais je le garde dans un coin de ma tête.
Comment ça fonctionne step-by-step ?
• J'exécute le script PowerShell pour tout convertir :
C'est beau sa fonctionne
STEP 2
j'ouvre mon petit Excel et je fais du ménage en appuyant sur le gros boutons pour supprimer les macros (j'aurais aimé faire tout en une seul manip mais j'ai testé plein de chose)
Remove Macro :
Sub RemoveSpecificVBAComponents()
On Error GoTo ErrorHandler
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim fso As Object, folder As Object, file As Object
Dim i As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set sheet = ThisWorkbook.Sheets("config")
folderPath = sheet.Range("C3").Value
Set folder = fso.GetFolder(folderPath)
For Each file In folder.Files
DoEvents
fileName = file.Name
If LCase(fso.GetExtensionName(fileName)) = "xlsm" Or LCase(fso.GetExtensionName(fileName)) = "xlsb" Then
Debug.Print "Ouverture du fichier : " & fileName
Set wb = Workbooks.Open(file.path)
On Error Resume Next
With wb.VBProject
If Err.Number <> 0 Then
Debug.Print "Erreur d'accès à VBProject pour " & fileName & ": " & Err.Description
Err.Clear
GoTo SkipFile
End If
' Suppression des UserForms et des modules
RemoveVBAComponents wb
' Vider le code dans ThisWorkbook
ClearThisWorkbook wb
End With
On Error GoTo ErrorHandler
SkipFile:
If Not wb Is Nothing Then
Debug.Print "Sauvegarde et fermeture du fichier : " & fileName
wb.Close SaveChanges:=True
Set wb = Nothing
End If
Else
Debug.Print "Le fichier n'est pas un classeur Excel avec macros : " & fileName
End If
Next file
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Debug.Print "Les composants VBA spécifiques ont été supprimés ou vidés des classeurs."
Exit Sub
ErrorHandler:
Debug.Print "Erreur générale avec le fichier : " & fileName & "; Erreur #" & Err.Number & ": " & Err.Description
If Not wb Is Nothing Then
wb.Close SaveChanges:=False
Set wb = Nothing
End If
Resume Next
End Sub
Sub ClearThisWorkbook(wb As Workbook)
With wb.VBProject.VBComponents("ThisWorkbook").CodeModule
.DeleteLines 1, .CountOfLines
End With
End Subpuis boom premier problème, la macro fonctionne une fois sur 12 ou du moins, la macro crash mais pas Excel juste la macro se stop d'un coup une fois sur 12 (d'ou mon appel à l'aide)
Pour le scnd bouton c'est la même rengaine, au moment de l'éxecution la macro fonctionne sur certains document puis crash :
STEP 3
J'ai exporter au préalable mes userform en .frm et mon thisworkbook :
Du coup je demande à ma petite macro d'aller les cherchers pour les mettres dans mes 2280 (je précise que tout les tests on était effectué sur une dizaine de document pas directement sur les 2280)
Sub UpdateAllWorkbooks()
Dim folderPath As String
Dim sheet As Worksheet
Dim prevAutomationSecurity As MsoAutomationSecurity
' Sauvegarde le niveau de sécurité actuel
prevAutomationSecurity = Application.AutomationSecurity
' Définit le niveau de sécurité pour désactiver toutes les macros
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set sheet = ThisWorkbook.Sheets("config")
' Lire le chemin du dossier à partir de la cellule C3
folderPath = sheet.Range("C3").Value
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
' Appeler la fonction d'importation avec le chemin du dossier
ImportModulesAndForms folderPath
' Restaure le niveau de sécurité précédent à la fin de la macro
Application.AutomationSecurity = prevAutomationSecurity
End Sub
Function ReadUTF8FileContent(filePath As String) As String()
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 2
stream.Charset = "utf-8"
stream.Open
stream.LoadFromFile filePath
ReadUTF8FileContent = Split(stream.ReadText, vbCrLf)
stream.Close
End Function
Sub ImportModulesAndForms(ByVal folderPath As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sourceFolder As String
sourceFolder = "C:\Users\apprenti.info\Desktop\macro vba\FRC\macro des noms\export\" ' Chemin du dossier source
Dim folder As Object
Set folder = fso.GetFolder(folderPath)
Dim file As Object
For Each file In folder.Files
If fso.GetExtensionName(file.Name) = "xlsm" Then
Dim thisWorkbookContent() As String
thisWorkbookContent = ReadUTF8FileContent(sourceFolder & "ThisWorkbook.cls") ' Utilisez la nouvelle fonction ici
Debug.Print "Traitement du fichier: " & file.path
OpenWorkbookAndUpdateThisWorkbook file.path, sourceFolder, thisWorkbookContent
End If
Next file
Dim subfolder As Object
For Each subfolder In folder.subfolders
ImportModulesAndForms subfolder.path
Next subfolder
End Sub
Sub OpenWorkbookAndUpdateThisWorkbook(filePath As String, sourceFolder As String, thisWorkbookContent() As String)
On Error GoTo ErrHandler
Dim wb As Workbook
Dim fso As Object
Dim password As String
DoEvents
Set fso = CreateObject("Scripting.FileSystemObject")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
password = "unmdp"
' Vérifiez si le fichier existe
If Not fso.FileExists(filePath) Then
Debug.Print "Le fichier n'existe pas: " & filePath
GoTo NextFile
End If
' Vérifiez si le classeur est déjà ouvert
If IsWorkbookOpen(filePath) Then
Debug.Print "Le classeur est déjà ouvert: " & filePath
GoTo NextFile
End If
Set wb = Workbooks.Open(filePath, password:=password)
' Désactive le partage si activé
If wb.MultiUserEditing Then
wb.ExclusiveAccess
End If
' Mettez ici votre logique pour mettre à jour le classeur
' Enregistrez et fermez le classeur
If Not wb Is Nothing Then
If Not wb.Saved Then wb.Save
wb.Close SaveChanges:=True
End If
NextFile:
' Réinitialise les paramètres d'Application
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
ErrHandler:
Debug.Print "Une erreur est survenue: " & Err.Description, vbCritical
If Not wb Is Nothing Then
wb.Close SaveChanges:=False
Set wb = Nothing
End If
Resume NextFile
End Sub
Function IsWorkbookOpen(fileName As String) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Application.Workbooks(fileName)
On Error GoTo 0
IsWorkbookOpen = Not wb Is Nothing
End Function
'
'Sub RemoveExistingComponents(wb As Workbook)
' Dim vbComp As Object
'
' For Each vbComp In wb.VBProject.VBComponents
' ' Exclure ThisWorkbook, Sheet1, Sheet2, etc.
' If vbComp.Type = vbext_ct_MSForm Or vbComp.Type = vbext_ct_StdModule Or vbComp.Type = vbext_ct_ClassModule Then
' wb.VBProject.VBComponents.Remove vbComp
' End If
' Next vbComp
'End Sub
Sub ImportComponents(wb As Workbook, sourceFolder As String)
Dim vbComp As Object
Dim fileName As String
Dim fileExtension As String
fileExtension = "frm" ' l'extension des fichiers à importer
' Suppression des UserForms existants si nécessaire
Dim componentNames As New Collection
componentNames.Add "UserForm1"
componentNames.Add "search"
Dim compName As Variant
For Each compName In componentNames
DoEvents
For Each vbComp In wb.VBProject.VBComponents
DoEvents
If vbComp.Name = compName Then
wb.VBProject.VBComponents.Remove vbComp
Exit For ' Sortir de la boucle une fois trouvé et supprimé
End If
Next vbComp
Next compName
' Importation des fichiers .frm
fileName = Dir(sourceFolder & "*." & fileExtension)
While fileName <> ""
DoEvents
' Vérifiez si le fichier est un .frm avant de l'importer
If LCase(Right(fileName, Len(fileExtension))) = LCase(fileExtension) Then
wb.VBProject.VBComponents.Import sourceFolder & fileName
End If
fileName = Dir() ' Obtenez le prochain fichier correspondant
Wend
End Sub
'Sub ImportComponents(wb As Workbook, sourceFolder As String)
' Dim vbComp As Object
' Dim fileName As String
'
' ' Importation de ThisWorkbook.cls
' ' Note : ThisWorkbook ne peut pas être supprimé, mais son contenu peut être modifié si nécessaire.
'
' ' Importation de UserForm1.frm et UserForm1.frx
' fileName = Dir(sourceFolder & "UserForm1.frm")
' If fileName <> "" Then
' wb.VBProject.VBComponents.Import sourceFolder & fileName
' End If
'End Sub
Sub UpdateThisWorkbookContent(wb As Workbook, content() As String)
Dim vbComp As Object
Set vbComp = wb.VBProject.VBComponents("ThisWorkbook")
With vbComp.CodeModule
DoEvents
.DeleteLines 1, .CountOfLines
Dim line As Variant
Dim startLine As Long: startLine = 1
For Each line In content
.InsertLines startLine, line
startLine = startLine + 1
Next line
End With
End Sub
Function CorrectEncoding(sourcePath As String) As String()
Dim fileContent As String
Dim fileLines() As String
Dim i As Integer
' Lire le contenu du fichier
fileContent = ReadUTF8FileContent(sourcePath)
' Diviser le contenu en lignes
fileLines = Split(fileContent, vbCrLf)
' Parcourir chaque ligne et remplacer les caractères mal encodés
For i = LBound(fileLines) To UBound(fileLines)
DoEvents
' Remplacer les caractères mal encodés ici ---------------
fileLines(i) = Replace(fileLines(i), "?", "é") ' Exemple pour 'é'
Next i
' Le tableau fileLines est déjà une chaîne de lignes corrigées
CorrectEncoding = fileLines
End Functionj'hésite à changer de langage de programmation pour du c# mais je préfère voir avec les experts d'Excel si ils ont une meilleurs solutions pour moi
Cordialement,
UnMecQuiGalère
Salut,
C'est la macro de suppression de code qui fonctionne 1 fois sur 12 ?
Je vois que tu supprime l'ensemble du code sans distinction. Pourquoi ne pas laisser faire Excel ? si tu détectes du code, alors faire une sauvegarde en xlsx en désactivant les confirmations Non ?
Salut,
C'est la macro dans sa globalité, pour plus de précision c'est ici que la macro crash généralement :
C'est le cas autant pour la suppression que l'ajout, le crash se produit tout le temps à l'ouverture de l'Excel (On boucle un ou deux, puis un seul reste bêtement ouvert le script s'étant stopper.).
Pour l'exemple je viens de réeffectué 3 tests :
- Bouclé sur un dossier qui contient 20 Excels. (Fonctionnel, je dois juste faire un script pour convertir les chaines de charactères correctement "é" ou "à" mais le code s'importe bien
- Bouclé sur un dossier qui contient 2 sous-dossiers pour une vingtaine d'Excel répartie entre les 3 dossiers (Fonctionnel, même soucis de mauvaise conversion "UTF-8")
- Bouclé sur un dossier qui contient 220 Excels (Arrivé un moment la macro crash, la routine s'arrête.)
Je me permet de remonter la conversation attendant un peu plus d'aide :)
Bonjour,
ça veut dire quoi la macro stoppe ?
Pas de message d'erreur ?
Ce n'est pas sur des gros fichiers ? En premier lieu je testerai en ajoutant une tempo après le Workbooks.Open(file.path) pour lui laisser un peu de temps
Sur serveur tu es tributaire du réseau, peut-être que ça coince un peu de temps en temps en plus (?)
eric
Edit: je ne vois pas de On Error Goto 0 pour réinitialiser la gestion d'erreur. Pas sûr du tout que le .Clear suffise.
Ca te masque peut-être une erreur plus loin que tu devrais voir
Bonjour, Merci Eric de votre réponse.
Effectivement, je ne peux mieux exprimer le problème :
- La macro s'arrête
• Théorie : Excel ne bloquerait il pas une trop grande interaction avec le vba à la minute et/ou demi-heure ?
Le phénomène ne se produit pas toujours du premier coup, généralement j'arrive à exécuter la macro une première fois mais dès qu'on atteint l'importation des modules sur le ~150ièmes fichier excel. La macro se stop (Est-ce une mise en sécurité expliqué nul part ?)
Concernant la théorie du réseau je pense que ça peux jouer aussi, bien que mes tests sont fait sur mon bureau (qui est certes sur le réseau) mais le transfert se passe du réseau au réseau sur ma VM donc bonne question ?
Concernant les GoTo 0 effectivement, j'ai modifié merci.
Bonjour,
elle s'arrête comme si elle avait fini, sans message et sans ligne signalée en jaune dans le code ?
Je n'ai jamais vu ça...
Le phénomène ne se produit pas toujours du premier coup, généralement j'arrive à exécuter la macro une première fois mais dès qu'on atteint l'importation des modules sur le ~150ièmes fichier excel. La macro se stop (Est-ce une mise en sécurité expliqué nul part ?)
Non, pas de 'mise en sécurité'
Si c'est toujours vers 150 fichiers, ça ferait plutôt penser à une pile saturée. Mais 150 c'est petit pour une pile...
Teste quand même avec une tempo après ouverture du fichier pour éliminer cette piste
eric
Bonjour Eric, merci de votre réponse.
J'ai déjà testé en marquant une pause dans le processus de "une seconde" mais ça n'a pas changer. J'ai fais une petite vidéo du comportement de la macro mais je ne peux envoyer de liens ici malheureusement.