XL 2013 VBA synthèse base de données sans doublons

H

Honor

XLDnaute Nouveau
Bonjour,

J'ai une feuille "data" où :
- on peut avoir plusieurs fois le même identifiant pour un type différent (A1 à A..)
- une quantité est associé à chaque identifiant pour un type donné
- un libellé désigne un même identifiant

Je souhaite sur ma feuille synthèse :
- avoir en colonne A mes identifiants dans l'ordre croissant sans doublons
- avoir en colonne B le libellé correspondant à l'identifiant
- avoir en ligne 1 de la colonne C à la colonne ... suivant le nombre de type existant (variable)
- ensuite je calcule le total en fonction des 2 critères (type et identifiant)
- en dernière ligne je cherche le total de chacune des colonnes.
J'ai un pb au niveau de l'apparition de ma ligne 1, les types se collent en colonne et non en ligne..

Merci d'avance si vous avez des idées :)
 

Pièces jointes

  • exemple.xlsm
    23.2 KB · Affichages: 60
  • exemple.xlsm
    23.2 KB · Affichages: 71
Trier par date Trier par votes
klin89

klin89

XLDnaute Accro
Re : VBA synthèse base de données sans doublons

Bonsoir Honor, R@chid le forum, :)

A tester :
VB: 
Option Explicit

Sub test()
Dim x, a, b(), i As Long, j As Long, n As Long, temp, txt As String
    With Sheets("data").Cells(1).CurrentRegion
        a = .Value
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & _
                 ",,,row(1:" & .Rows.Count & "))," & .Columns(3).Address & ")=1, " & _
                  .Columns(3).Address & ",char(2)))"), Chr(2), 0)
        ReDim b(1 To .Rows.Count, 1 To UBound(x) + 2)
        b(1, 1) = "Identifiant": b(1, 2) = "Libellé"
        For i = 1 To UBound(x)
            b(1, i + 2) = x(i)
        Next
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = .Count + 2
                    For j = 1 To 2
                        b(.Item(txt), j) = a(i, j)
                    Next
                End If
                temp = Application.Match(a(i, 3), x, 0)
                b(.Item(txt), temp + 1) = b(.Item(txt), temp + 1) + a(i, 4)
            Next
            n = .Count + 1
        End With
    End With
    Application.ScreenUpdating = False
    'Restitution
    With Sheets("synthèse").Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(b, 2)).Value = b
        With .CurrentRegion
            With .Offset(.Rows.Count, 2).Resize(1, .Columns.Count - 2)
                .Formula = "=sum(r2c:r[-1]c)"
            End With
            .Offset(.Rows.Count).Cells(1).Value = "Total"
        End With
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            With .Rows(.Rows.Count)
                .Interior.ColorIndex = 19
                .BorderAround Weight:=xlThin
            End With
            .Columns("a:b").ColumnWidth = Array(12, 9)
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub
klin89
 
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : VBA synthèse base de données sans doublons

Bonjour,

Voir PJ

http://boisgontierjacques.free.fr/fichiers/Cellules/Stat2D2.xls

Les dictionnaires permettent d'indexer les lignes et colonnes du tableau Tstat() et ainsi d'accélérer la recherche .

Code: 
Sub Stat2D()
  Set f1 = Sheets("data")
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set d3 = CreateObject("Scripting.Dictionary")
  Tbl = f1.Range("a2:d" & f1.[A65000].End(xlUp).Row)
  For i = 1 To UBound(Tbl): d1(Tbl(i, 1)) = "": d2(Tbl(i, 3)) = "": Next
  Dim TStat(): ReDim TStat(1 To d1.Count, 1 To d2.Count)
  Dim Tcol: ReDim Tcol(1 To d2.Count): Dim Tlig: ReDim Tlig(1 To d1.Count)
  lig = 1: col = 1
  Mlig = lig:  Mcol = col
  d1.RemoveAll: d2.RemoveAll
  For i = 1 To UBound(Tbl)
    If d1.exists(Tbl(i, 1)) Then lig = d1(Tbl(i, 1)) Else d3(Tbl(i, 2)) = "": d1(Tbl(i, 1)) = Mlig: lig = Mlig: Mlig = Mlig + 1
    If d2.exists(Tbl(i, 3)) Then col = d2(Tbl(i, 3)) Else d2(Tbl(i, 3)) = Mcol: col = Mcol: Mcol = Mcol + 1
      TStat(lig, col) = TStat(lig, col) + Tbl(i, 4)
      Tlig(lig) = Tlig(lig) + Tbl(i, 4)
      Tcol(col) = Tcol(col) + Tbl(i, 4)
    Next i
    Set f2 = Sheets("synthèse")
    f2.[a2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    f2.[b2].Resize(d3.Count, 1) = Application.Transpose(d3.keys)
    f2.[c1].Resize(1, d2.Count) = d2.keys
    f2.[c2].Resize(d1.Count, d2.Count) = TStat
    f2.[c2].Offset(d1.Count).Resize(, d2.Count) = Tcol
    f2.[c2].Offset(, d2.Count).Resize(d1.Count) = Application.Transpose(Tlig)
    '-- tri
    [a2].Resize(d1.Count, d2.Count + 3).Sort key1:=[a2], Header:=xlNo
    '-- présentation
    'f2.[c2].Resize(d1.Count, d2.Count).SpecialCells(4) = 0
    f2.[a2].Resize(d1.Count, 1).BorderAround Weight:=xlThin
    f2.[b2].Resize(d3.Count, 1).BorderAround Weight:=xlThin
    f2.[c1].Resize(1, d2.Count + 1).BorderAround Weight:=xlThin
    f2.[c2].Resize(d1.Count, d2.Count).BorderAround Weight:=xlThin
    f2.[a2].Offset(d1.Count).Resize(, d2.Count + 3).BorderAround Weight:=xlThin
    f2.[c1].Offset(, d2.Count).Resize(d1.Count + 2).BorderAround Weight:=xlThin
    For k = 1 To d2.Count: f2.[c1].Offset(, k - 1).Resize(d1.Count + 2).BorderAround Weight:=xlThin: Next
End Sub

JB
 

Pièces jointes

  • Stat2D2.xls
    58.5 KB · Affichages: 66
  • Stat2D2.xls
    58.5 KB · Affichages: 62
Dernière édition:
Vote positif 0 Vote négatif
H

Honor

XLDnaute Nouveau
Re : VBA synthèse base de données sans doublons

merci pour toutes vos réponses, c'est super!
Je viens de me mettre à VBA..je ne comprends pas toutes les lignes notamment avec l'utilisation du Ubound et des tableaux à redimensionner..je suis sur les tutos d'explications ;)

D'autre part, est ce que vous avez des pistes pour remplacer les cellules vides par des 0 ? même si je ne souhaite pas l'affichage des mes colonnes ou lignes vides..

Merci encore!
 
Vote positif 0 Vote négatif
H

Honor

XLDnaute Nouveau
Re : VBA synthèse base de données sans doublons

JB est ce que tu pourrais juste me donner quelques indications pour mieux comprendre comment tu as obtenu le code.. surtout sur le début du code par rapport au dimensionnement des tableaux, utilisation de ubound et des différents dicctionnaires..merci d'avance :)
 
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : VBA synthèse base de données sans doublons

Re Honor,
Bonjour JB,

VB: 
Option Explicit

Sub test()
Dim x, a, b(), i As Long, j As Long, n As Long, temp, txt As String
    With Sheets("data").Cells(1).CurrentRegion
        a = .Value
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & _
            ",,,row(1:" & .Rows.Count & "))," & .Columns(3).Address & ")=1, " & _
            .Columns(3).Address & ",char(2)))"), Chr(2), 0)
        ReDim b(1 To .Rows.Count, 1 To UBound(x) + 2)
        b(1, 1) = "Identifiant": b(1, 2) = "Libellé"
        For i = 1 To UBound(x)
            b(1, i + 2) = x(i)
        Next
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = .Count + 2
                    For j = 1 To 2
                        b(.Item(txt), j) = a(i, j)
                    Next
                End If
                temp = Application.Match(a(i, 3), x, 0)
                b(.Item(txt), temp + 1) = b(.Item(txt), temp + 1) + a(i, 4)
            Next
            n = .Count + 1
        End With
    End With
    Application.ScreenUpdating = False
    'Restitution
    With Sheets("synthèse").Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(b, 2)).Value = b
        With .CurrentRegion
            On Error Resume Next
            .SpecialCells(4) = 0
            On Error GoTo 0
            .Cells(1).Resize(.Rows.Count, .Columns.Count).Sort key1:=.Cells(1), Header:=xlYes
            With .Offset(.Rows.Count, 2).Resize(1, .Columns.Count - 2)
                .Formula = "=sum(r2c:r[-1]c)"
            End With
            .Offset(.Rows.Count).Cells(1).Value = "Total"
        End With
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Columns(1).NumberFormat = "000000"
            With .Rows(1)
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            With .Rows(.Rows.Count)
                .Interior.ColorIndex = 19
                .BorderAround Weight:=xlThin
            End With
            .Columns("a:b").ColumnWidth = Array(12, 9)
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub
klin89
 
Dernière édition:
Vote positif 0 Vote négatif
H

Honor

XLDnaute Nouveau
Re : VBA synthèse base de données sans doublons

Merci! est ce que vous pouvez juste me donner quelques commentaires pour le début du code svp..merci d'avance.. je suis un peu perdue.. je ne vois pas pourquoi on créée les variables : Mcol, col, mlign, et lign à la fois ?
 
Vote positif 0 Vote négatif
H

Honor

XLDnaute Nouveau
Re : VBA synthèse base de données sans doublons

Bonsoir,
j'essaie de mieux comprence ce code..mais j'ai toujours des difficulté à voir à quoi correspondent les variables Mlign et Mcol ?
mais surtout la partie en bleu...


Sub Stat2D()
Set f1 = Sheets("data")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Tbl = f1.Range("a2:d" & f1.[A65000].End(xlUp).Row)

For i = 1 To UBound(Tbl): d1(Tbl(i, 1)) = "": d2(Tbl(i, 3)) = "": Next
Dim TStat(): ReDim TStat(1 To d1.Count, 1 To d2.Count)
Dim Tcol: ReDim Tcol(1 To d2.Count): Dim Tlig: ReDim Tlig(1 To d1.Count)
lig = 1: col = 1
Mlig = lig: Mcol = col
d1.RemoveAll: d2.RemoveAll

For i = 1 To UBound(Tbl)
If d1.exists(Tbl(i, 1)) Then lig = d1(Tbl(i, 1)) Else d3(Tbl(i, 2)) = "": d1(Tbl(i, 1)) = Mlig: lig = Mlig: Mlig = Mlig + 1
If d2.exists(Tbl(i, 3)) Then col = d2(Tbl(i, 3)) Else d2(Tbl(i, 3)) = Mcol: col = Mcol: Mcol = Mcol + 1
TStat(lig, col) = TStat(lig, col) + Tbl(i, 4)
Tlig(lig) = Tlig(lig) + Tbl(i, 4)
Tcol(col) = Tcol(col) + Tbl(i, 4)
Next i

Set f2 = Sheets("synthèse")
f2.[a2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
f2.[b2].Resize(d3.Count, 1) = Application.Transpose(d3.keys)
f2.[c1].Resize(1, d2.Count) = d2.keys
f2.[c2].Resize(d1.Count, d2.Count) = TStat
f2.[c2].Offset(d1.Count).Resize(, d2.Count) = Tcol
f2.[c2].Offset(, d2.Count).Resize(d1.Count) = Application.Transpose(Tlig)

'-- tri
[a2].Resize(d1.Count, d2.Count + 3).Sort key1:=[a2], Header:=xlNo

'-- présentation
'f2.[c2].Resize(d1.Count, d2.Count).SpecialCells(4) = 0
f2.[a2].Resize(d1.Count, 1).BorderAround Weight:=xlThin
f2.[b2].Resize(d3.Count, 1).BorderAround Weight:=xlThin
f2.[c1].Resize(1, d2.Count + 1).BorderAround Weight:=xlThin
f2.[c2].Resize(d1.Count, d2.Count).BorderAround Weight:=xlThin
f2.[a2].Offset(d1.Count).Resize(, d2.Count + 3).BorderAround Weight:=xlThin
f2.[c1].Offset(, d2.Count).Resize(d1.Count + 2).BorderAround Weight:=xlThin
For k = 1 To d2.Count: f2.[c1].Offset(, k - 1).Resize(d1.Count + 2).BorderAround Weight:=xlThin: Next
End Sub
 
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : VBA synthèse base de données sans doublons

Bonjour,

-La BD est transférée dans une table Tbl(,) pour la rapidité d'accès.
-Les stats sont effectuées dans un tableau Tstat()
-Pour retrouver plus rapidement la ligne et la colonne du tableau Tstat(,) où effectuer le cumul, on indexe celui ci avec 2 dictionnaires d1 et d2
-Mlig représente le numéro de ligne maxi du dictionnaire d1. A chaque fois qu'une clé n'est pas trouvée dans le dictionnaire, on l'ajoute avec le numéro de ligne maxi.

Stat2D2.gif

JB
 

Pièces jointes

  • Stat2D2.xls
    68 KB · Affichages: 50
  • Stat2D2.xls
    68 KB · Affichages: 46
Dernière édition:
Vote positif 0 Vote négatif
H

Honor

XLDnaute Nouveau
Re : VBA synthèse base de données sans doublons

ok merci je commence à comprendre!! Merci beaucoup!!

J'ai repris un code en l'adaptant à mon cas pour créer des boutons de navigation: premier, dernier, précédent, suivant..
cependant j'ai des erreurs.. avez vous des idées comment coder ces boutons.

Mon appli sur excel si besoin ;)

Merci d'avance! :)
 

Pièces jointes

  • oicag 12.xlsm
    101.3 KB · Affichages: 47
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
XL 2019 Extraire des lignes suivant somme des colonnes pour alimenter un autre tableau
Réponses
1
Affichages
224
fanfan38
fanfan38
C
  • Résolu(e)
XL 2013 Synthèse TCD liée à des segments sans doublons
Réponses
1
Affichages
299
Chrystel01
C
I
  • Question
Microsoft 365 Renommer des fichiers avec des caractères non reconnus
Réponses
10
Affichages
439
ivan27
I
H
  • Question
Autres mise a jour automatique feuille excel vba
Réponses
2
Affichages
288
HANN
H
V
  • Résolu(e)
XL 2016 Facturier : Retour à la ligne sur la facture
2
Réponses
19
Affichages
558
Vermithor
V
T
  • Question
XL 2016 SI INDEX EQUIV Doublons...
Réponses
8
Affichages
172
Titiem
T
M
  • Question
Microsoft 365 Colonne de la feuille 1 envoyer en une ligne sur la feuille 2
Réponses
0
Affichages
308
marcmarc
M
F
  • Résolu(e)
XL 2021 recherche doublons dans colonne puis suppression des lignes
Réponses
5
Affichages
174
ftpo69
F
P
  • Question
Power Pivot Filtrer une somme en fonction de filtres sur un graphique
Réponses
2
Affichages
188
Pierre111
P
hypo78
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
18
Affichages
563
Lolote83
L

Membres actuellement en ligne

13 membres et 155 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 202
Messages
2 086 177
Membres
103 152
dernier inscrit
Karibu