Regroupement de colonnes automatisé par macro VBA

kokosei

XLDnaute Nouveau
Bonjour,

J'essaye de réaliser une macro pour faire une mise en forme automatique d'un fichier.

Pour résumer, nous générons une liste de données chaque semaine. Celle-ci va être retraité automatiquement par des tableaux croisés, qui sont présent sur plusieurs feuilles. Les pivots seront donc automatiquement régénéréspar le biais de "refreshall".

Par la suite, on doit traiter les données et les mettre en forme afin de les rendre lisibles. On a donc recours à une option "groupement des colonnes". mais les colonnes changent à chaque fois d'emplacement, donc on est obligé de le faire manuellement, ce qui prend au vu du nombre d'onglets et de la longueur des TC près d'une heure trente.

je n'ai guère envie de devoir le faire tout le temps car cela ne génére que peu de valeur ajoutée, et pour être franc, si une macro peut le faire à ma place en 2 minutes, pourquoi se priver?

Ce que j'ai fait en amont:
-Une formule donne une indication "1" pour spécifier la première colonne à selectionner, puis la même formule indique avec un "2" quand la sélection doit se terminer. ceci est valable pour toute les feuilles.
-L'idée ensuite est d'effacer la valeur 1 et 2 à chaque fois afin de pouvoir relancer la macro jusqu'à ce qu'une cellule (somme) me dise qu'il n'y a plus de 1 ou de 2.

le problème, c'est que comme c'est un tableau croisé, les titres peuvent être fusionnés ce qui signifie que la macro sélectionne tout le tableau croisé alors qu'elle ne devrait prendre qu'une partie limitée de celui-ci.
j'ai essayé de trouver une autre solution, par ce biais là, mais cela ne fonctionne pas du tout, et je ne sais pas pourquoi.

voir macro, en dessous :


'----------------------------------------------------------------------------------------------------------------


Sub Regroupementcolonne()

' Code permettant de faire des regroupements de colonnes afin de mettre en forme de maniére automatique les données.

Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Select
'Code permettant de dire que la macro doit s´appliquer pour toute les feuilles du fichier,
'WS (Worksheet) indique que on devra utiliser le code pour l´ensemble des feuilles existantes

'Worksheets (Array("Total", "Privat", "Privat+WZ"))

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
'Dis à la macro d´ouvrir tout les volets fermés dans les colonnes

Columns("BK:IZ").Select
Selection.Columns.Ungroup
' De BK à IZ, selectionne l´ensemble des colonnes puis enléve les volets.

Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[1]:RC[255])"
'Insertion d´une ligne afin de pouvoir y rajouter ma fonction somme. cette fonction somme situé
'en A1 permet de vérifier si il existe encore des onglets à créer ou non.




Range("BK1").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[18]C[-2]=""Gesamt: MIX"",1,IF(AND(R[10]C[1]<>"""",R[10]C[2]<>""""),2,IF(AND(R[18]C="""",R[19]C=""""),"""",IF(ISERROR(VLOOKUP(R[19]C,Tabelle1!R3C4:R100C5,2,0)),(IF(ISERROR(VLOOKUP(R[18]C,Tabelle1!R4C1:R100C2,2,0)),"""",VLOOKUP(R[18]C,Tabelle1!R4C1:R100C2,2,0))),VLOOKUP(R[19]C,Tabelle1!R3C4:R100C5,2,0)))))"
'On rentre la formule permettant de calculer si il s´agit de la premiére colonne et de la derniére colonne à masquer.

Range("BK1").Select
Selection.AutoFill Destination:=Range("BK1:IY1"), Type:=xlFillDefault
Range("BK1:IY1").Select
' Avec la formule défini ici, nous disons que toute les celulles entre BK et LY1 doivent avoir la meme formule que celle que l´on vient de rentrer.

Range("IZ1").Select
ActiveCell.FormulaR1C1 = "2"
' Permet de mettre un 2 afin de dire à la macro de fermer le dernier onglet de la feuille. Les TC ne sont jamais jusqu´ici arrivé au dela de IZ.


Do While Range("A1") <> 0
' Si la fonction somme dit qu´il y a encore des onglets "1" ou "2", alors elle doit faire ceci:

Dim Firstcol As String
Dim Lastcol As String
'First = premiére colonne du volet à créer
' Last= derniére colonne du volet à créer

Range("BK1:IZ1").Select
Firstcol = Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, lookat _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Columns
' Est censé définir le nom de la colonne ou commence la selection de création des volets
Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, lookat _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
Selection.Clear
'Effacer la premiére valeur 1 que nous avons trouvé

Range("BK1:IZ1").Select
Lastcol = Selection.Find(What:="2", After:=ActiveCell, LookIn:=xlValues, lookat _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Columns

Selection.Find(What:="2", After:=ActiveCell, LookIn:=xlValues, lookat _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
Selection.Clear
'Effacer la premiére valeur 2 que nous avons trouvé

'------------------------------------------------------------------------------------------------------------

Cells(1, Firstcol).Select
' Cellule( Ligne 1, collone définie par la macro)=> eX: BZ1

Range(Selection, Cells(1, Lastcol)).Select
' Selectionner de BZ1 jusqu´á la seconde colonne défini, en ne prenant que la 1ere ligne
'afin d´eviter le 1er probléme rencontré, c´est á dire la présence de celulles fusionnées.

Selection.Columns.Group
' Regrouper les collones selectionnées

Loop
'Appliquer la condition jusqu´à ce qu´il n´y est plus ni de 1 ni de 2.

'=> ICI SE SITUE PROBABLEMENT LE PROBLEME QUE JE RENCONTRE

'------------------------------------------------------------------------------------------------------------

ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
' Fermer les volets de la feuille afin de permettre une meilleure visibilitée.

Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Effacer la premiére ligne que nous avons crée.

Next ws
' Passer à la feuille suivante.

End Sub


Si quelqu'un peut voir ou se situe l'erreur ou avoir une autre proposition de méthode, je suis preneur :)

cordialement,
 

Discussions similaires