Regroupement données sur une feuille

[melanie18]

Bonjour

J'ai deux feuilles AM1 et AM2 avec des données.
Pour la feuille AM1, pour chaque numéro j'ai un solde restant AM1 mais je n'ai pas le solde AM2 qui est sur
la feuille 2.

Je souhaite regrouper les données AM1 et AM2 sur une feuille "Résultats"
Pour chaque numéro (ColA), il peut y avoir soit seulement le solde AM1, soit seulement le solde AM2, soit les 2 en résultats.

Dans la feuille "Résultats" je souhaite donc afficher tous les numéros en regroupant AM1 et AM2 sur la même ligne (numéro) ET aussi les lignes où il y a que l'AM1 ou AM2 en solde.

Merci 🙂

Exemple fichier

http://demo.ovh.eu/fr/59cd11b571d07ee42f3100f502567dd8/

 

[melanie18]

Re : Regroupement données sur une feuille

J'ai testé le dernier fichier joint.

J'ai rajouté une ligne en dessous de la tienne avec le même numéro 444444 et des infos en AM2 et solde

Sur la feuil résul il m'affiche exactement la même ligne en ligne 13.

Normalement, il devrait mettre à jour la ligne déjà existante 44444 avec les infos AM2 et solde, vu qu'il en existe déjà une.

Je récapitule :
Un numéro (colA) peut avoir soit :
-des données AM1 et solde
-des données AM2 et solde
-les deux répartis sur deux lignes

Le but étant de regrouper sur une ligne ces données AM1/solde et AM2/solde pour un même numéro

et qu'il m'affiche aussi les autres lignes où il y a juste des données AM1/solde OU AM2/solde pour les autres numéros qui n'ont pas de "doublons"

 

[CISCO]

Re : Regroupement données sur une feuille

Bonsoir

J'ai rajouté des info en colonnes G et H sur la feuille regroupement et elles ont bien été reportées sur la feuille résul (Attention au format des N° en colonne A, 444444 par exemple en lignes 12 et 13).

 

[melanie18]

Re : Regroupement données sur une feuille

Bonjour

Effectivement, sans doute un problème de format, avec le dernier fichier, ça marche.

Maintenant, faut que je teste avec mon fichier original, j'ai testé rapidement hier soir, ça n'a pas marché. 🙁 😕

Dès que j'ai un moment, je refais le test.

Merci Cisco

 

[melanie18]

Re : Regroupement données sur une feuille

Bonjour

J'ai testé sur mon fichier original, ça marche impeccable. 😀

J'aurai voulu faire la même chose avec un autre fichier.

Mais cette fois ci au lieu d'avoir dans ma base deux colonnes pour AM avec solde pour chacun, je n'ai qu'une colonne AM.

Je souhaite donc faire la même chose, regrouper les doublons N° sur une ligne et affichage des autres lignes bien entendu sans doublons.
J'ai donc rajouté deux colonnes AM2 et solde dans la feuille résult

Merci

 

[klin89]

Re : Regroupement données sur une feuille

Bonsoir Mélanie, le forum

Le code dans le module 1.
Résultat en feuille "result".

Option Explicit

Sub Regroupement()
Dim a, i As Long, j As Long, n As Long, col As Byte, w
    a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
    col = UBound(a, 2): n = 1
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = VBA.Array(n, col)
                For j = 1 To col
                    a(n, j) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + 2
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                    a(1, w(1) - 1) = a(1, 5) & 2
                    a(1, w(1)) = a(1, 6)
                End If
                For j = 1 To 2
                    a(w(0), w(1) - 2 + j) = a(i, j + 4)
                Next
                .Item(a(i, 1)) = w
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("result").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[melanie18]

Re : Regroupement données sur une feuille

Bonsoir klin89

Impressionnant ton truc 🙂

Y'a juste à cliquer, il me sort un tableau tout fait.

Je t'avoue que j'ai rien compris au code mais je vais regarder de plus près. 😉

J'ai mis les donnés de mon fichier original, en un clic c'est fait. 😎


Merci

 

[klin89]

Re : Regroupement données sur une feuille

Re Mélanie,

Pour le fun, essaies celle-ci, le code est dans le module 2.

Option Explicit

Sub Regroupement1()
Dim a, i As Long, j As Long, n As Long, col As Byte, w
    a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
    col = UBound(a, 2): n = 1
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = VBA.Array(n, col)
                For j = 1 To col
                    a(n, j) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + 2
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                    a(1, w(1) - 1) = a(1, 5) & 1
                    a(1, w(1)) = a(1, 6)
                End If
                For j = 1 To 2
                    a(w(0), w(1) - 2 + j) = a(i, j + 4)
                Next
                .Item(a(i, 1)) = w
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("result").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
        End With
        If UBound(a, 2) > 8 Then
            With .Offset(, 6).Resize(1, 2)
                .AutoFill .Resize(, UBound(a, 2) - 6)
            End With
        End If
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

Le code réajusté :

Sub Regroupement2()
Dim a, i As Long, j As Long, n As Long, col As Byte, w
    a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 5) = "AM1"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = VBA.Array(n, col)
                For j = 1 To col
                    a(n, j) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + 2
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                    a(1, w(1) - 1) = a(1, 5)
                    a(1, w(1)) = a(1, 6)
                End If
                For j = 1 To 2
                    a(w(0), w(1) - 2 + j) = a(i, j + 4)
                Next
                .Item(a(i, 1)) = w
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("result").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 38
                .BorderAround Weight:=xlThin
            End With
        End With
        If UBound(a, 2) > 6 Then
            With .Offset(, 4).Resize(1, 2)
                .AutoFill .Resize(, UBound(a, 2) - 4)
            End With
        End If
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89