cumul de plusieurs tableaux excel 2007

excel_lence · 14 Mars 2016

Salut le forum

J'ai besoin de cumuler plusieurs tableaux en un seul, soit par des formules ou TCD ou vba

toute aide est la bien venue.

pour cela je joins un fichier base.

Merci d'avance.

chris · 14 Mars 2016

Re : cumul de plusieurs tableaux excel 2007

Bonjour

Tu n'as pas posté au bon endroit.

Quoi qu'il en soit cela dépend ce que tu veux faire.

Le TCD sert à synthétiser or ton exemple rassemble le détail...

Dans les 2 cas tu peux utiliser Ms query pour combiner les sources : un exemple ici Ce lien n'existe plus

klin89 · 17 Avril 2016

Re : cumul de plusieurs tableaux excel 2007

Bonjour chris, excel_lence, le forum

Essaie ceci :
Au préalable, crée la Feuil1.

VB:

Option Explicit

Sub test()
Dim a, i As Long, w(), n, y, e, v
    a = Sheets("2014").Range("b2").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = _
                CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            If Not .Item(a(i, 1)).exists(a(i, 3)) Then
                ReDim w(1 To 5)
                w(1) = a(i, 1): w(2) = a(i, 3): w(3) = a(i, 5)
                .Item(a(i, 1))(a(i, 3)) = w
            Else
                w = .Item(a(i, 1))(a(i, 3))
                w(3) = w(3) + a(i, 5)
                .Item(a(i, 1))(a(i, 3)) = w
            End If
        Next
        a = Sheets("2015").Range("b2").CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = _
                CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            If Not .Item(a(i, 1)).exists(a(i, 3)) Then
                ReDim w(1 To 5)
                w(1) = a(i, 1): w(2) = a(i, 3): w(4) = a(i, 5)
                .Item(a(i, 1))(a(i, 3)) = w
            Else
                w = .Item(a(i, 1))(a(i, 3))
                w(4) = w(4) + a(i, 5)
                .Item(a(i, 1))(a(i, 3)) = w
            End If
        Next
        For Each e In .keys
            For Each v In .Item(e).keys
                w = .Item(e)(v)
                w(5) = w(3) + w(4)
                .Item(e)(v) = w
            Next
        Next
        y = .items
    End With
    'Restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1)
        .Parent.Cells.Clear
        With .Resize(1, 5)
            .Value = Array("Nom", "Contrat n°", "2014", "2015", "Total")
            .Interior.ColorIndex = 36
            .HorizontalAlignment = xlCenter
        End With
        n = n + .CurrentRegion.Rows.Count
        For i = 0 To UBound(y)
            With .Offset(n).Resize(y(i).Count, 5)
                .Columns(2).NumberFormat = "@"
                .Value = _
                Application.Transpose(Application.Transpose(y(i).items))
                n = n + .Rows.Count + 1
            End With
            With .Offset(n - 1).Cells(1).Resize(, 5)
                .Value = Array("", "Total", _
                               "=sum(r" & n - y(i).Count & "c:r[-1]c)", _
                               "=sum(r" & n - y(i).Count & "c:r[-1]c)", _
                               "=sum(r" & n - y(i).Count & "c:r[-1]c)")
                .Interior.ColorIndex = 44
            End With
        Next
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            With .Offset(1).Resize(.Rows.Count - 1)
                .Columns("c:e").NumberFormat = "#,##0.00"
            End With
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

excel_lence · 18 Avril 2016

Re : cumul de plusieurs tableaux excel 2007

Salut klin89,

Je te remercie pour ta contribution. je commencais à désesperer.

Ta solution me va bien mais je vais exageré en demandant plus

Est il possible de choisir les onglets à cumuler, par exemple si j'ai de 2010 à 2016 je ne veux cumulé que les onglets voulus,
donc le choix des onglets va se faire par un bouton des choix.

Merci d'avance.

klin89 · 21 Avril 2016

Re : cumul de plusieurs tableaux excel 2007

Re excel_lence,

Pour faire simple, tu peux sélectionner tes feuilles manuellement, on utilisera alors la propriété SelectedSheets. (voir l'aide VBA)
Après tu peux réaliser quelque chose de plus sophistiqué pour la sélection de tes feuilles, mais bon le jeu en vaut-il la chandelle

VB:

Option Explicit

Sub test()
Dim a, b(), w(), y, e, v
Dim ws As Worksheet, i As Long, n As Long, t As Byte, ub As Byte
    If ActiveWindow.SelectedSheets.Count > 1 Then
        ub = ActiveWindow.SelectedSheets.Count + 3
        ReDim b(1 To ub): n = 2
        For Each ws In ActiveWindow.SelectedSheets
            n = n + 1: b(n) = ws.Name
        Next ws
        b(1) = "Nom": b(2) = "Contrat n°": b(ub) = "Total"
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1: t = 2
            For Each ws In ActiveWindow.SelectedSheets
                a = Sheets(ws.Name).Range("b2").CurrentRegion.Value
                t = t + 1
                For i = 2 To UBound(a, 1)
                    If Not .exists(a(i, 1)) Then
                        Set .Item(a(i, 1)) = _
                        CreateObject("Scripting.Dictionary")
                        .Item(a(i, 1)).CompareMode = 1
                    End If
                    If Not .Item(a(i, 1)).exists(a(i, 3)) Then
                        ReDim w(1 To ub)
                        w(1) = a(i, 1): w(2) = a(i, 3): w(t) = a(i, 5)
                        .Item(a(i, 1))(a(i, 3)) = w
                    Else
                        w = .Item(a(i, 1))(a(i, 3))
                        w(t) = w(t) + a(i, 5)
                        .Item(a(i, 1))(a(i, 3)) = w
                    End If
                Next
            Next
            For Each e In .keys
                For Each v In .Item(e).keys
                    w = .Item(e)(v)
                    w(UBound(w)) = Application.Sum(Application.Index(w, Evaluate("row(3:" & UBound(w) - 1 & ")")))
                    .Item(e)(v) = w
                Next
            Next
            y = .items
        End With
        'Restitution et mise en forme
        Application.ScreenUpdating = False
        With Sheets("Feuil1").Cells(1)
            .Parent.Cells.Clear: n = 0
            With .Resize(1, ub)
                .Value = b
                .Interior.ColorIndex = 36
                .HorizontalAlignment = xlCenter
            End With
            n = n + .CurrentRegion.Rows.Count
            For i = 0 To UBound(y)
                With .Offset(n).Resize(y(i).Count, ub)
                    .Columns(2).NumberFormat = "@"
                    .Value = _
                    Application.Transpose(Application.Transpose(y(i).items))
                    n = n + .Rows.Count + 1
                End With
                With .Offset(n - 1)
                    .Cells(1, 1).Resize(, ub).Interior.ColorIndex = 42
                    .Cells(1, 2).Value = "Total"
                    .Cells(1, 3).Formula = "=sum(r" & n - y(i).Count & "c:r[-1]c)"
                    .Cells(1, 3).AutoFill .Cells(1, 3).Resize(, ub - 2)
                End With
            Next
            With .CurrentRegion
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Borders(xlInsideHorizontal).Weight = xlThin
                With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
                    .NumberFormat = "#,##0.00"
                End With
            End With
            .Parent.Activate
        End With
        Application.ScreenUpdating = True
    Else
        MsgBox "Vous devez sélectionner au moins 2 feuilles"
    End If
End Sub

klin89

klin89 · 23 Avril 2016

Re : cumul de plusieurs tableaux excel 2007

Re excel_lence,

Tu peux aussi passer par un UserForm.
Tu y implantes un contrôle CommandButton et un contrôle ListBox.
Dans le module de l'UserForm, tu insères ces 2 codes.

VB:

Private Sub UserForm_Initialize()
Dim ws As Worksheet
    With ListBox1
        .MultiSelect = fmMultiSelectMulti
        For Each ws In Worksheets
            If ws.Name <> "cumul" Then
                .AddItem ws.Name
            End If
        Next ws
    End With
End Sub

VB:

Private Sub CommandButton1_Click()
Dim Tablo(), n As Byte
    Me.Hide
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                n = n + 1
                ReDim Preserve Tablo(1 To n)
                Tablo(n) = .List(i, 0)
                .Selected(i) = False
            End If
        Next
    End With
    If n > 0 Then
        Unload Me
        Call test1(Tablo)
    Else
        MsgBox "Vous devez sélectionner au moins 1 feuille"
        Me.Show
    End If
End Sub

Dans un module standard, place ce code :

VB:

Option Explicit

Sub test1(Tablo())
Dim a, b(), w(), y, e, v
Dim i As Long, n As Long, t As Byte, ub As Byte
    ub = UBound(Tablo) + 3
    ReDim b(1 To ub): n = 2
    For Each e In Tablo
        n = n + 1: b(n) = e
    Next
    b(1) = "Nom": b(2) = "Contrat n°": b(ub) = "Total"
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: t = 2
        For Each e In Tablo
            a = Sheets(e).Range("b2").CurrentRegion.Value
            t = t + 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = _
                    CreateObject("Scripting.Dictionary")
                    .Item(a(i, 1)).CompareMode = 1
                End If
                If Not .Item(a(i, 1)).exists(a(i, 3)) Then
                    ReDim w(1 To ub)
                    w(1) = a(i, 1): w(2) = a(i, 3): w(t) = a(i, 5)
                    .Item(a(i, 1))(a(i, 3)) = w
                Else
                    w = .Item(a(i, 1))(a(i, 3))
                    w(t) = w(t) + a(i, 5)
                    .Item(a(i, 1))(a(i, 3)) = w
                End If
            Next
        Next
        For Each e In .keys
            For Each v In .Item(e).keys
                w = .Item(e)(v)
                w(UBound(w)) = Application.Sum(Application.Index(w, Evaluate("row(3:" & UBound(w) - 1 & ")")))
                .Item(e)(v) = w
            Next
        Next
        y = .items
    End With
    'Restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets("Cumul").Cells(1)
        .Parent.Cells.Clear: n = 0
        With .Resize(1, ub)
            .Value = b
            .Interior.ColorIndex = 36
            .HorizontalAlignment = xlCenter
        End With
        n = n + .CurrentRegion.Rows.count
        For i = 0 To UBound(y)
            With .Offset(n).Resize(y(i).count, ub)
                .Columns(2).NumberFormat = "@"
                .Value = _
                Application.Transpose(Application.Transpose(y(i).items))
                n = n + .Rows.count + 1
            End With
            With .Offset(n - 1)
                .Cells(1, 1).Resize(, ub).Interior.ColorIndex = 42
                .Cells(1, 2).Value = "Total"
                .Cells(1, 3).Formula = "=sum(r" & n - y(i).count & "c:r[-1]c)"
                .Cells(1, 3).AutoFill .Cells(1, 3).Resize(, ub - 2)
            End With
        Next
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            With .Offset(1, 2).Resize(.Rows.count - 1, .Columns.count - 2)
                .NumberFormat = "#,##0.00"
            End With
        End With
        '.Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Dans le module de la feuille "Cumul"
Insère cette macro événementielle, n'oublie pas de créer le bouton sur la feuille.

VB:

Private Sub CommandButton1_Click()
UserForm1.Show
End Sub

klin89

excel_lence · 25 Avril 2016

Re : cumul de plusieurs tableaux excel 2007

Re klin89,

Merci beaucoup de ton aide.

Effectuez une recherche sur Excel Downloads...

cumul de plusieurs tableaux excel 2007

excel_lence

XLDnaute Nouveau

Pièces jointes

chris

XLDnaute Barbatruc

klin89

XLDnaute Accro

excel_lence

XLDnaute Nouveau

klin89

XLDnaute Accro

klin89

XLDnaute Accro

Pièces jointes

excel_lence

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums