Bonjour tout le monde, j'ai une macro qui doit faire les choses suivantes :
1/ la macro récupère la valeur de type entier, en cellule B5 dans l'onglet "parametres" du fichier excel nommé "MacroMajMoisCexAg.xlsx". Cette valeur est un numéro de mois de type entier qui va donc de 1 à 12 maximum.
Le format de la cellule B5 est de type "standard"
2/ la macro va parcourir tous les fichiers qui se trouve dans le même répertoire que le fichier excel nommé "MacroMajMoisCexAg.xlsx"
3/ la macro repère les fichiers excel
4/ la macro ouvre le premier fichier excel par ordre alphabétique
5/ la macro va changer le filtre "[Dim Calendrier].[MoisNoComptabilsation].[MoisNoComptabilsation]" des tcd suivants (attention, il y a d'autres champs dans les filtres qu'il ne faut pas toucher)
la fenêtre de filtres met du temps à s’afficher manuellement (environ 5 secondes), cela peut être un facteur affectant la performance et le fonctionnement de la macro.
il faut jouter une temporisation de 10 secondes après chaque mise à jour de TCD
Les tcd dont il faut appliquer la valeur en B5 sont les suivants :
RtMois : mettre la valeur de B5
DetailCptesM : mettre la valeur de B5
RtYtd : mettre les valeur de 1 à B5
DetailCptesYtd : mettre les valeur de 1 à B5
!!!! attention : le champ "[Dim Calendrier].[MoisNoComptabilsation]" est de type texte, il faut le gérer aussi
!!!! attention : le champ "[Dim Calendrier].[MoisNoComptabilsation]" se trouve dans la zone "filtre" des tcd
8/ la macro met à jour tous les tcd du fichiers excel
9/ la macro attend que l'actualisation de tous les tcd soit finie
10/ la macro renomme le fichier de la façon suivante : remplacer la valeur qui est comprise entre le "-" et le ".xlsx" par la valeur B5, attention, ce qui est avant le "-" ne doit pas être modifié
11/ferme le fichier
12/ la macro ouvre le fichier excel suivant dans le répertoire et refait la même chose c'est-à-dire du 1 au 12 jusqu'à avoir appliqué la procédure à tous les fichiers excel à l'exception du fichier excel nommé "MacroMajMoisCexAg.xlsx"
Voici la macro qui fonctionne uniquement sur les tcd RtMois et DetailCptesM. Mais pas les 2 autres.
Je ne sais pas si le pb vient du fait que RtMois et DetailCptesM sont dans le même onglet, et pas les 2 autres qui sont chacun dans un onglet différent...
Je ne peux joindre de fichier car étant donné qu'il s'agit d'un "analyze in excel", vous n'aurez pas les droits pour actualiser les tcd...
Sub MiseAJourFiltresString()
Dim dossier As String
Dim fichier As String
Dim fichierPrincipal As String
Dim mois As String
Dim valeurMax As Integer
Dim wbPrincipal As Workbook
Dim wbAutre As Workbook
Dim tcd As PivotTable
Dim champ As PivotField
Dim visibleItems() As String
Dim msg As String
Dim i As Integer
' Initialisation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' Le fichier principal
fichierPrincipal = ThisWorkbook.Name
Set wbPrincipal = ThisWorkbook
' Récupérer la valeur de B5 dans l'onglet "parametres"
mois = CStr(wbPrincipal.Sheets("parametres").Range("B5").Value)
valeurMax = CInt(mois)
' Construire une liste des valeurs de "1" à mois (format string)
ReDim visibleItems(1 To valeurMax)
For i = 1 To valeurMax
visibleItems(i) = "[Dim Calendrier].[MoisNoComptabilsation].&[" & i & "]"
Next i
' Chemin du répertoire contenant les fichiers
dossier = wbPrincipal.Path
If Right(dossier, 1) <> "\" Then dossier = dossier & "\"
' Lister les fichiers Excel dans le répertoire
fichier = Dir(dossier & "*.xlsx")
' Parcourir tous les fichiers
Do While fichier <> ""
If fichier <> fichierPrincipal Then
' Ouvrir le fichier
Set wbAutre = Workbooks.Open(dossier & fichier)
' Parcourir les TCD et appliquer les filtres
On Error Resume Next
For Each tcd In wbAutre.Worksheets("Resultats").PivotTables
Set champ = tcd.PivotFields("[Dim Calendrier].[MoisNoComptabilsation].[MoisNoComptabilsation]")
If Not champ Is Nothing Then
' Réinitialiser les filtres
champ.ClearAllFilters
Application.Wait Now + TimeValue("0:00:10") ' Temporisation après ClearAllFilters
' Appliquer les filtres
If tcd.Name = "RtMois" Or tcd.Name = "DetailCptesM" Then
champ.VisibleItemsList = Array("[Dim Calendrier].[MoisNoComptabilsation].&[" & mois & "]")
ElseIf tcd.Name = "RtYtd" Or tcd.Name = "DetailCptesYtd" Then
champ.VisibleItemsList = visibleItems
End If
Application.Wait Now + TimeValue("0:00:10") ' Temporisation après VisibleItemsList
' Afficher un message pour debug
Debug.Print "Filtres appliqués pour TCD : " & tcd.Name
Else
Debug.Print "Champ introuvable pour TCD : " & tcd.Name
End If
Next tcd
On Error GoTo 0
' Actualiser tous les TCD
wbAutre.RefreshAll
' Fermer le fichier
wbAutre.Close SaveChanges:=True
End If
fichier = Dir ' Passer au fichier suivant
Loop
' Nettoyage
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Mise à jour des filtres terminée.", vbInformation
End Sub
' Fonction pour renommer les fichiers sans ajouter de second "-"
Function RenommerFichierCorrige(dossier As String, fichier As String, mois As String) As String
Dim debutNom As String
Dim finNom As String
Dim positionTiret As Long
Dim positionExtension As Long
' Identifier les positions du dernier tiret "-" et de ".xlsx"
positionTiret = InStrRev(fichier, "-")
positionExtension = InStrRev(fichier, ".xlsx")
' Si les positions sont valides, construire le nouveau nom
If positionTiret > 0 And positionExtension > positionTiret Then
debutNom = Left(fichier, positionTiret - 1) ' Partie avant le tiret
finNom = "-" & mois & ".xlsx" ' Nouvelle valeur et extension
RenommerFichierCorrige = dossier & debutNom & finNom
Else
' Si problème, conserver le fichier inchangé
RenommerFichierCorrige = dossier & fichier
End If
End Function
1/ la macro récupère la valeur de type entier, en cellule B5 dans l'onglet "parametres" du fichier excel nommé "MacroMajMoisCexAg.xlsx". Cette valeur est un numéro de mois de type entier qui va donc de 1 à 12 maximum.
Le format de la cellule B5 est de type "standard"
2/ la macro va parcourir tous les fichiers qui se trouve dans le même répertoire que le fichier excel nommé "MacroMajMoisCexAg.xlsx"
3/ la macro repère les fichiers excel
4/ la macro ouvre le premier fichier excel par ordre alphabétique
5/ la macro va changer le filtre "[Dim Calendrier].[MoisNoComptabilsation].[MoisNoComptabilsation]" des tcd suivants (attention, il y a d'autres champs dans les filtres qu'il ne faut pas toucher)
la fenêtre de filtres met du temps à s’afficher manuellement (environ 5 secondes), cela peut être un facteur affectant la performance et le fonctionnement de la macro.
il faut jouter une temporisation de 10 secondes après chaque mise à jour de TCD
Les tcd dont il faut appliquer la valeur en B5 sont les suivants :
RtMois : mettre la valeur de B5
DetailCptesM : mettre la valeur de B5
RtYtd : mettre les valeur de 1 à B5
DetailCptesYtd : mettre les valeur de 1 à B5
!!!! attention : le champ "[Dim Calendrier].[MoisNoComptabilsation]" est de type texte, il faut le gérer aussi
!!!! attention : le champ "[Dim Calendrier].[MoisNoComptabilsation]" se trouve dans la zone "filtre" des tcd
8/ la macro met à jour tous les tcd du fichiers excel
9/ la macro attend que l'actualisation de tous les tcd soit finie
10/ la macro renomme le fichier de la façon suivante : remplacer la valeur qui est comprise entre le "-" et le ".xlsx" par la valeur B5, attention, ce qui est avant le "-" ne doit pas être modifié
11/ferme le fichier
12/ la macro ouvre le fichier excel suivant dans le répertoire et refait la même chose c'est-à-dire du 1 au 12 jusqu'à avoir appliqué la procédure à tous les fichiers excel à l'exception du fichier excel nommé "MacroMajMoisCexAg.xlsx"
Voici la macro qui fonctionne uniquement sur les tcd RtMois et DetailCptesM. Mais pas les 2 autres.
Je ne sais pas si le pb vient du fait que RtMois et DetailCptesM sont dans le même onglet, et pas les 2 autres qui sont chacun dans un onglet différent...
Je ne peux joindre de fichier car étant donné qu'il s'agit d'un "analyze in excel", vous n'aurez pas les droits pour actualiser les tcd...
Sub MiseAJourFiltresString()
Dim dossier As String
Dim fichier As String
Dim fichierPrincipal As String
Dim mois As String
Dim valeurMax As Integer
Dim wbPrincipal As Workbook
Dim wbAutre As Workbook
Dim tcd As PivotTable
Dim champ As PivotField
Dim visibleItems() As String
Dim msg As String
Dim i As Integer
' Initialisation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' Le fichier principal
fichierPrincipal = ThisWorkbook.Name
Set wbPrincipal = ThisWorkbook
' Récupérer la valeur de B5 dans l'onglet "parametres"
mois = CStr(wbPrincipal.Sheets("parametres").Range("B5").Value)
valeurMax = CInt(mois)
' Construire une liste des valeurs de "1" à mois (format string)
ReDim visibleItems(1 To valeurMax)
For i = 1 To valeurMax
visibleItems(i) = "[Dim Calendrier].[MoisNoComptabilsation].&[" & i & "]"
Next i
' Chemin du répertoire contenant les fichiers
dossier = wbPrincipal.Path
If Right(dossier, 1) <> "\" Then dossier = dossier & "\"
' Lister les fichiers Excel dans le répertoire
fichier = Dir(dossier & "*.xlsx")
' Parcourir tous les fichiers
Do While fichier <> ""
If fichier <> fichierPrincipal Then
' Ouvrir le fichier
Set wbAutre = Workbooks.Open(dossier & fichier)
' Parcourir les TCD et appliquer les filtres
On Error Resume Next
For Each tcd In wbAutre.Worksheets("Resultats").PivotTables
Set champ = tcd.PivotFields("[Dim Calendrier].[MoisNoComptabilsation].[MoisNoComptabilsation]")
If Not champ Is Nothing Then
' Réinitialiser les filtres
champ.ClearAllFilters
Application.Wait Now + TimeValue("0:00:10") ' Temporisation après ClearAllFilters
' Appliquer les filtres
If tcd.Name = "RtMois" Or tcd.Name = "DetailCptesM" Then
champ.VisibleItemsList = Array("[Dim Calendrier].[MoisNoComptabilsation].&[" & mois & "]")
ElseIf tcd.Name = "RtYtd" Or tcd.Name = "DetailCptesYtd" Then
champ.VisibleItemsList = visibleItems
End If
Application.Wait Now + TimeValue("0:00:10") ' Temporisation après VisibleItemsList
' Afficher un message pour debug
Debug.Print "Filtres appliqués pour TCD : " & tcd.Name
Else
Debug.Print "Champ introuvable pour TCD : " & tcd.Name
End If
Next tcd
On Error GoTo 0
' Actualiser tous les TCD
wbAutre.RefreshAll
' Fermer le fichier
wbAutre.Close SaveChanges:=True
End If
fichier = Dir ' Passer au fichier suivant
Loop
' Nettoyage
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Mise à jour des filtres terminée.", vbInformation
End Sub
' Fonction pour renommer les fichiers sans ajouter de second "-"
Function RenommerFichierCorrige(dossier As String, fichier As String, mois As String) As String
Dim debutNom As String
Dim finNom As String
Dim positionTiret As Long
Dim positionExtension As Long
' Identifier les positions du dernier tiret "-" et de ".xlsx"
positionTiret = InStrRev(fichier, "-")
positionExtension = InStrRev(fichier, ".xlsx")
' Si les positions sont valides, construire le nouveau nom
If positionTiret > 0 And positionExtension > positionTiret Then
debutNom = Left(fichier, positionTiret - 1) ' Partie avant le tiret
finNom = "-" & mois & ".xlsx" ' Nouvelle valeur et extension
RenommerFichierCorrige = dossier & debutNom & finNom
Else
' Si problème, conserver le fichier inchangé
RenommerFichierCorrige = dossier & fichier
End If
End Function