Automatiser un consolidé

Le 25/08/2016 à 19:37

Bonsoir,

Je sollicite votre aide afin de trouver une solution qui me permettra de gagner du temps dans la consolidation de données statistiques que je reçois trimestriellement, dans mon exemple se sont des tableaux identiques qui dans la pratique sont plus importants que ça, je les ai nommés région centre, région nord, région est et région ouest.

1 ) Premièrement : je voudrai automatiser le « consolidé global » dont le tableau est identique aux 5 premiers

2) Deuxièmement : je voudrai avoir un consolidé par code de la colonne « A » c'est-à-dire de C1 à C10 et par région. Actuellement, je fais ça manuellement et ça demande un temps fou.

Existe-il un code VBA pour automatiser tout ça…?

Je ne sais pas si mes explications sont intelligibles

Merci par avance pour votre aide

14exemple.xlsx (25.73 Ko)
Le 25/08/2016 à 20:03

Bonjour, Shen

pourrais-tu mettre des exemples chiffrés dans tes tableaux ?

amicalement

Pierrot

Le 25/08/2016 à 20:41

Bonsoir Pierrot,

Voici l'exemple avec des données chiffrées, j'ai renseigné les 5 premiers tableaux (les régions), le consolidé global et à titre d'exemple le tableau de la feuille "C1"

Merci à vous

15exemple-chiffre.xlsx (26.96 Ko)
Le 25/08/2016 à 21:08

Bonsoir,

Avec la formule en E2: =SOMME(C2:D2) et tirer vers le bas avec la petite croix en bas de la cellule

Pierrot

13exemple-chiffre-shen.xlsm (27.69 Ko)
Le 25/08/2016 à 21:17

Bonjour,

Pour la question 1 c'est facile (voir pièce jointe)

Pour la question 2 c'est une autre histoire... En fait il ne s'agit plus de consolider mais d'éclater et regrouper.

Là effectivement VBA me semble indispensable !

A+

18exemple-chiffre-vg.xlsx (26.71 Ko)
Le 25/08/2016 à 21:39

Tout à fait galopin01, vous avez traduit exactement ce que je voulais !

Merci pour vos réponses, en attendant le code miracle s'il existe...

Le 25/08/2016 à 23:35

Bonsoir à tous,

Pour la question 2, vois ceci :

Option Explicit
Sub test()
Dim a, w(), e, s, x, i As Long, j As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each s In Array("Region Centre", "Region Nord", "Région Sud", "Région Est", "Région Ouest")
            a = Sheets(s).Cells(1).CurrentRegion
            x = Split(s)
            For i = 2 To UBound(a, 1) - 1
                If Not .exists(a(i, 1)) Then
                    ReDim w(1 To 5, 1 To 2)
                    w(1, 1) = "Régions": w(2, 1) = a(1, 2): w(3, 1) = a(1, 3)
                    w(4, 1) = a(1, 4): w(5, 1) = a(1, 5)
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(1 To 5, 1 To UBound(w, 2) + 1)
                End If
                w(1, UBound(w, 2)) = x(1)
                For j = 2 To UBound(a, 2)
                    w(j, UBound(w, 2)) = a(i, j)
                Next
                .Item(a(i, 1)) = w
            Next
        Next
        For Each e In .keys
            If Not IsSheetExists(e) Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
            End If
            w = .Item(e)
            With Sheets(e).Cells(1)
                .CurrentRegion.Clear
                With .Resize(UBound(w, 2), UBound(w, 1))
                    .Value = Application.Transpose(w)
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .HorizontalAlignment = xlCenter
                        .Interior.ColorIndex = 40
                        .Font.Size = 11
                    End With
                    .Columns.ColumnWidth = 15
                    .Rows.RowHeight = 18
                End With
            End With
        Next
    End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

klin89

Le 26/08/2016 à 01:22

Chapeau klin89 !! Merci beaucoup, ça marche impec !

Là, je vais essayer d'adapter ce code à mon tableau qui contient en réalité 56 lignes et 13 colonnes et si jamais je n'y arrive pas permettez-moi de revenir vers vous...Merci encore, c'est super !

Le 26/08/2016 à 16:18

La macro proposée par klin89 marche parfaitement bien et réponds exactement à mes attentes, sauf que j’aurais dû mettre en ligne les tableaux tels qu’ils sont réellement, en fait j’ai essayé d’adapter le code VBA proposé plus haut mais je n’y arrive pas car je ne dispose pas des connaissances nécessaires en la matière, je reviens vers vous donc avec le fichier "test2" ci-dessous avec les tableaux réels.

Merci d'avance pour votre aide

Cordialement,

9test2.xlsx (462.35 Ko)
Le 26/08/2016 à 17:33

Bonjour,

Voir en pièce jointe.

Attention : il manquait la feuille "C4" Je l'ai rajouté car à l'inverse de klin ma macro ne fait aucun contrôle : Elle suppose que toutes les feuilles existent.

Avantage : Il n'y a que trois lignes de paramètres facilement modifiable si tu dois rajouter une région ou une colonne...

Le fichier :

3shen-vg1.xlsm (501.15 Ko)

Attention : il est possible que ce fichier ne fonctionne pas correctement sur ton répertoire de téléchargement.

Dans ce cas il faudra l'enregistrer dans ton répertoire de travail Excel.

A+

Le 26/08/2016 à 18:49

Re Shen,

Bonjour galopin01,

Dans le nouvel exemple, il faut donc parcourir les 45 premières feuilles.

Au bas de chaque nouvelle feuille restituée, faut-il effectuer les totaux 

Option Explicit
Sub test()
Dim a, w(), e, s As Byte, i As Long, j As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        'Boucle sur les 45 premieres feuilles de ton classeur
        For s = 1 To 45
            a = Sheets(s).Cells(1).CurrentRegion
            For i = 2 To UBound(a, 1) - 1
                If Not .exists(a(i, 1)) Then
                    ReDim w(1 To 12, 1 To 2)
                    w(1, 1) = "Régions"
                    For j = 2 To UBound(a, 2)
                        w(j, 1) = a(1, j)
                    Next
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(1 To 12, 1 To UBound(w, 2) + 1)
                End If
                w(1, UBound(w, 2)) = Sheets(s).Name
                For j = 2 To UBound(a, 2)
                    w(j, UBound(w, 2)) = a(i, j)
                Next
                .Item(a(i, 1)) = w
            Next
        Next
        For Each e In .keys
            If Not IsSheetExists(e) Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
            End If
            w = .Item(e)
            With Sheets(e).Cells(1)
                .CurrentRegion.Clear
                With .Resize(UBound(w, 2), UBound(w, 1))
                    .Value = Application.Transpose(w)
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Columns.ColumnWidth = 15
                    .Rows.RowHeight = 16
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .HorizontalAlignment = xlCenter
                        .Interior.ColorIndex = 40
                        .Font.Size = 11
                        .WrapText = True
                        .Rows.RowHeight = 36
                    End With
                End With
            End With
        Next
    End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

klin89

Le 26/08/2016 à 20:56

Bonsoir à tous,

@galopin01 : ça marche impec, sans aucun soucis ! un grand merci pour votre aide

@klin89 : au sujet des totaux, oui ce serait utile de les inclure, désolé de ne pas l'avoir préciser. Par contre, à l'exécution de la macro certaines "régions" manquent dans les tableaux générés (de C1 à C26), en l’occurrence les régions 45, 46, 47, 48 et 49.

Un grand merci également, j'ai maintenant l'embarras du choix ...

Le 27/08/2016 à 00:45

Finalement, je me suis rendu compte que j'ai oublié quelques feuilles, j'ai rectifié pour la boucle c'est 49 au lieu de 45, c'est parfait !

Un big Merci à vous deux

Cordialement,

Shen

Le 31/08/2016 à 16:32

Re Shen,

Cette version avec les totaux effectués au bas de chaque tableaux

Option Explicit
Sub test()
Dim a, w(), e, s As Byte, i As Long, j As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        'Boucle sur les 45 premieres feuilles de ton classeur
        For s = 1 To 45
            a = Sheets(s).Cells(1).CurrentRegion
            For i = 2 To UBound(a, 1) - 1
                If Not .exists(a(i, 1)) Then
                    ReDim w(1 To 12, 1 To 3)
                    w(1, 1) = "Régions"
                    For j = 2 To UBound(a, 2)
                        w(j, 1) = a(1, j)
                    Next
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(1 To 12, 1 To UBound(w, 2) + 1)
                End If
                w(1, UBound(w, 2) - 1) = Sheets(s).Name
                For j = 2 To UBound(a, 2)
                    w(j, UBound(w, 2) - 1) = a(i, j)
                Next
                .Item(a(i, 1)) = w
            Next
        Next
        For Each e In .keys
            If Not IsSheetExists(e) Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
            End If
            w = .Item(e)
            w(1, UBound(w, 2)) = "Totaux"
            For i = 2 To UBound(w, 1)
                w(i, UBound(w, 2)) = Application.Sum(Application.Index(w, i, Evaluate("row(2:" & UBound(w, 2) - 1 & ")")))
            Next
            .Item(e) = w
            With Sheets(e).Cells(1)
                .CurrentRegion.Clear
                With .Resize(UBound(w, 2), UBound(w, 1))
                    .Value = Application.Transpose(w)
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Columns.ColumnWidth = 15
                    .Rows.RowHeight = 16
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .HorizontalAlignment = xlCenter
                        .Interior.ColorIndex = 40
                        .Font.Size = 11
                        .WrapText = True
                        .Rows.RowHeight = 36
                    End With
                    With .Rows(UBound(w, 2))
                        .BorderAround Weight:=xlThin
                        .Interior.ColorIndex = 36
                        .Font.Size = 11
                        .Rows.RowHeight = 20
                    End With
                End With
            End With
        Next
    End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

klin89

Le 02/09/2016 à 20:18

Bonsoir Klin,

C'est génial, merci beaucoup pour votre aide et votre amabilité

Bonne soirée

Rechercher des sujets similaires à "automatiser consolide"