XL 2010 Fusion de fichiers partiellement identiques

Chubby · 7 Juillet 2016

Bonjour le forum,

La fusion de fichiers est traitée en long et en large et souvent par macro. Ce qui ne m'est pas adapté trop souvent en proie à qq problèmes. On voit aussi à l'aide de recherchev.
Avez vous d'autres solutions pour fusionner deux ou trois pages de données pas totalement identiques?
Je vous joins ces deux pages, une rouge, une bleue ...
Si vous aviez des idées.
Merci à vous

gosselien · 7 Juillet 2016

Bonjour,

Et tu n'expliques pas ce que tu veux faire exactement...
Il faut être + clair dans ta demande

P.

Chubby · 7 Juillet 2016

Bonsoir Gosselien et les zôtres,

Oui à la lecture de ton message je comprends mieux que le mien n'était pas clair.
Mon problème se résume de la sorte: je voudrais additionner la feuille 1 avec la 2 pour créer la 3. Les références ne sont pas obligatoirement communes même si en principe les colonnes sont respectées.
Je te joins un nouveau fichier noté avec 1, 2 et 3.
Merci de ton aide.

gosselien · 7 Juillet 2016

Re,

une tentative ...

P.

klin89 · 8 Juillet 2016

Bonsoir le fil,

Vois ceci :
Au préalable, crée la Feuil1 pour la restitution.

VB:

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, j As Long, n As Long, e, txt As String
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each e In Array("1", "2")
            a = Sheets(e).Range("a2").CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 6)), Chr(2))
                If Not .exists(txt) Then
                    ReDim w(1 To 7)
                    w(1) = a(i, 1)
                    For j = 6 To 11
                        w(j - 4) = a(i, j)
                    Next
                    .Item(txt) = w
                Else
                    w = .Item(txt)
                    For j = 7 To 11
                        w(j - 4) = w(j - 4) + a(i, j)
                    Next
                    .Item(txt) = w
                End If
            Next
        Next
        ReDim b(1 To .Count + 1, 1 To 7)
        n = n + 1
        b(n, 1) = a(1, 1)
        For j = 6 To 11
            b(n, j - 4) = a(n, j)
        Next
        For Each e In .keys
            w = .Item(e)
            n = n + 1
            For j = 1 To UBound(.Item(e))
                b(n, j) = .Item(e)(j)
            Next
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        .Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
          :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        .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 = 38
            With .Offset(, 2).Resize(, .Columns.Count - 2)
                .Interior.ColorIndex = 40
            End With
            With .Resize(, 2)
                .Interior.ColorIndex = 36
            End With
        End With
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Chubby · 8 Juillet 2016

Bonjour Gosselien, Bonjour klin89, et aux zôtres et bien bonjour,
Merci Gosselien et klin89, merci pour votre travail. Les macro m'effraient un peu je dois dire. Je plante souvent et je me retrouve sans solutions, donc j'hésite.
Ne peut on pas faire sans? ... je suis sur que si ;-)
Merci d'avance à vous deux, et aux zôtres.

Chubby · 9 Juillet 2016

Bonjour le forum,

J'ai un peu creusé mon histoire de fusion de fichier. Deux options:
- Il existe la fonctionnalité: consolidation dans le ruban de xls 2010 .... Résulta super sinon qu'il ne prend que la colonne la plus à gauche du tableau. Donc si tu as deux colonnes (dans mon cas appellation et Etiquette) a respecter ... c'est rapé. Mais peut être faut il travailler à partir d'une table de données et non d'un tableau. A voir
- On peut aussi mettre bout à bout (en dessous) les deux tableaux mis en base de données. Puis on se fait un TCD avec la forme tabulaire on a ainsi les deux colonnes de "légende" et leur cumul. On élimine les sous totaux.
Une fois cela fait on copie les valeurs du TCD, et on en fait un magnifique tableau où tout a été fusionné.
A mon sens, même si ça doit irriter les puristes, ce que je conçois, ça aide à la problématique.
Voir mon ti fichier.

N'hésitez pas à me faire vos remarques ... j'aime apprendre.
Bonne journée

gosselien · 9 Juillet 2016

Bonjour,

Si tu obtiens le résultat souhaité, que demander de plus ?
P.

Chubby · 10 Juillet 2016

Bonjour Gosselien, et les zôtres,
Je faisais part de ma façon de résoudre le problème tout simplement. Et comme je trouvais ça pas top élégant j'en avertissais ceux qui pouvaient améliorer cette méthode.
Bonne journée à toi et à tous

klin89 · 10 Juillet 2016

Re Chubby, le fil,

La donne a un poil changé
Avec le fichier du post #7.

VB:

Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, n As Long, e, y
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        'Attention au nom de tes feuilles dans l'array
        For Each e In Array("1", "2")
            a = Sheets(e).Range("a1").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, 2)) Then
                    ReDim w(1 To 7)
                    For j = 1 To 7
                        w(j) = a(i, j)
                    Next
                Else
                    w = .Item(a(i, 1))(a(i, 2))
                    For j = 3 To 7
                        w(j) = w(j) + a(i, j)
                    Next
                End If
                .Item(a(i, 1))(a(i, 2)) = w
            Next
        Next
        y = .items
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1)
        .CurrentRegion.Clear
        .Resize(1, UBound(a, 2)).Value = a
        n = n + .CurrentRegion.Rows.Count
        For i = 0 To UBound(y)
            With .Offset(n).Resize(y(i).Count, 7)
                .Value = _
                Application.Transpose(Application.Transpose(y(i).items))
                .BorderAround Weight:=xlThin
                If y(i).Count > 1 Then
                    .Offset(1).Resize(.Rows.Count - 1).Columns(1).ClearContents
                End If
                n = n + .Rows.Count
            End With
        Next
        With .CurrentRegion
            .Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
                :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .HorizontalAlignment = xlCenter
                With .Offset(, 2).Resize(, .Columns.Count - 2)
                    .Interior.ColorIndex = 40
                End With
                With .Resize(, 2)
                    .Interior.ColorIndex = 36
                End With
            End With
            .Columns("a:b").ColumnWidth = 23
            .Columns("c:g").ColumnWidth = 12
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Chubby · 11 Juillet 2016

Bonsoir klin89, bonsoir les zôtres,
J'ai modifié la donne non pas de départ mais comme étape intermédiaire à la manipulation que je décris plus loin. C'est pas des manipulations des plus esthétiques mais je contourne les difficultés.
Mais je te remercie klin pour ton intérêt. C'est toujours une source d'enrichissement pour tous ici.
Bonne fin de soirée

gosselien · 11 Juillet 2016

Bonjour,

ton fichier est un exemple bien sur mais j'obtiens 2 enregistrements pour le même vin, ce qui donne 2 lignes dans mon code avec dictionnaire bien sur , je ne sais pas si tu l'avais remarqué:
Coteaux Giennois blanc A B Blanc AOP La Gaupière
Coteaux Giennois blanc A R Rouge AOP La Gaupière

P.

XL 2010 Fusion de fichiers partiellement identiques

Chubby

XLDnaute Impliqué

Pièces jointes

gosselien

XLDnaute Barbatruc

Chubby

XLDnaute Impliqué

Pièces jointes

gosselien

XLDnaute Barbatruc

Pièces jointes

klin89

XLDnaute Accro

Chubby

XLDnaute Impliqué

Chubby

XLDnaute Impliqué

Pièces jointes

gosselien

XLDnaute Barbatruc

Chubby

XLDnaute Impliqué

klin89

XLDnaute Accro

Chubby

XLDnaute Impliqué

gosselien

XLDnaute Barbatruc

Discussions similaires