Bonjour,
J'ai besoin d 'aide svp pour résoudre un problème sur une macro qui auparavant marche et aujourd'hui elle ne fonctionne plus. Personne n'a touché au code, la seule chose qui a changée est l'environnement du travail. En fait c'est une macro que j'ai utilisé dans mon ancien boulot et aujourd'hui je change donc je l'apporte avec moi, mais !!!!
J'explique le fonctionnement de la macro: elle ouvre un ensemble de fichiers à partir d'un repertoire, applique un certains nombre de modifications, et ensuite elle ferment tout en enregistrant soit dans le même endroit soit ailleurs. voila le code de la macro. si quelqu'un peux m'aider svp ca sera cool,
'Paramètre
Dim chemin_source As String
Dim chemin_cible As String
Dim classeur As Object
Dim fonction As Variant
Dim indice As Integer
Dim fs, f, fc, f_crt As Variant
Sub traitement()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'parcour la liste des zones de saisie des répertoires
For indice = 1 To 45
'Mise à jour des liens
If UCase(Trim(Range("A4" ))) = "VRAI" Then
If UCase(Trim(Cells(8 + indice, 1))) = "VRAI" Then
chemin_source = Cells(8 + indice, 3)
If chemin_source <> "" Then
parcourir_repertoire
ElseIf chemin_source = "" Then
Cells(8 + indice, 3).Value = "non renseigné => traitement impossible"
End If
End If
'Autre que mise à jour des liens
Else
If UCase(Trim(Cells(8 + indice, 1))) = "VRAI" Then
chemin_cible = Cells(8 + indice + 1, 3)
chemin_source = Cells(8 + indice, 3)
If chemin_source <> "" And chemin_cible <> "" Then
parcourir_repertoire
Else
If chemin_source = "" Then Cells(8 + indice, 3).Value = "non renseigné => traitement impossible"
If chemin_cible = "" Then Cells(8 + indice + 1, 3).Value = "non renseigné => traitement impossible"
End If
End If
End If
Next
MsgBox ("Traitement terminé" )
End Sub
------------------------------------------------------------------------------------------------------------
Sub parcourir_repertoire()
Set fs = CreateObject("Scripting.FileSystemObject" )
Set f = fs.GetFolder(chemin_source)
Set fc = f.Files
'pour chaque fichier du répertoire, on applique les procédures ci-dessous
For Each f_crt In fc
'filtre uniquement les fichiers excel
If f_crt.Type = "Microsoft Excel Worksheet" Then
ouverture_fichier
' mise_en_forme
fermeture_fichier
End If
Next
End Sub
------------------------------------------------------------------------------------------------------------
Sub ouverture_fichier()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'updatelinks = 0 pas de mise à jour des liens
'updatelinks = 3 mise à jour des liens
If UCase(Trim(Range("A4" ))) = "VRAI" Then
Workbooks.Open f_crt, UpdateLinks:=3
Set classeur = ActiveWorkbook
Else
Workbooks.Open f_crt, UpdateLinks:=3
ActiveWorkbook.SaveAs chemin_cible & "\" & ActiveWorkbook.Name
Set classeur = ActiveWorkbook
End If
End Sub
------------------------------------------------------------------------------------------------------------
Sub fermeture_fichier()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
classeur.Worksheets(1).Activate
classeur.Save
classeur.Saved = True
classeur.Close
End Sub
------------------------------------------------------------------------------------------------------------
Sub mise_en_forme()
Dim i As Integer
Dim liaisons As Variant
ThisWorkbook.Worksheets(1).Activate
'Mise à jour des liens
If UCase(Trim(Range("A4" ))) = "VRAI" Then
'Il n'y a pas de mise en forme
'la mise jour des liens est effectuée à l'ouverture des classeurs
'Suppression des liens
ElseIf UCase(Trim(Range("A5" ))) = "VRAI" Then
'Détermine les liens de type Excel dans un tableau
classeur.Activate
liaisons = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
'Pour chaque liens du tableau, casser la liaison
'If Not IsEmpty(liaison) Then
If IsEmpty(liaisons) Then
'rien
Else
For i = 1 To UBound(liaisons)
ActiveWorkbook.BreakLink _
Name:=liaisons(i), _
Type:=xlLinkTypeExcelLinks
Next
End If
'Suppression des liens et formules
ElseIf UCase(Trim(Range("A6" ))) = "VRAI" Then
For i = 1 To Worksheets.Count
classeur.Worksheets(i).Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Cells(1, 1).Select
Next
End If
End Sub
Merci bcp pour votre aide.
