Fusionner deux feuilles avec données communes partielles

Bonjour à tous

Je bute lamentablement sur comment fusionner deux feuilles ( feuille "données A" et feuille "données B" sur exemple joint ) dont le point commun ( ex clients ) est partiel ( liste client )avec des données ( ex CA 2014 et 2015 ) pour ne faire qu'une seule feuille : ensemble des clients 2014 et 2015 et le CA sur une seule ligne ( feuille "fusion" faite manuellement sur exemple joint ) , merci de votre aide bien cordialement , DUPOU

Bonjour,

voilà

P.

Bonjour Patrick , je ne risquais pas de trouver avec des RechercheV et autre TC Dynamique . Je teste la fonction sur mes feuilles plus complexes que l'exemple . Merci beaucoup

Bonsoir à tous,

Vois ceci :

Option Explicit

Sub test()
Dim a, i As Long, w, x, y As Long, txt As String
    a = Sheets("données A").Range("a1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
            ReDim w(1 To 4)
            w(1) = a(i, 1): w(2) = a(i, 2): w(3) = a(i, 3)
            .Item(txt) = w
        Next
        a = Sheets("données B").Range("a1").CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
            If .exists(txt) Then
                w = .Item(txt)
                w(4) = a(i, 3)
            Else
                ReDim w(1 To 4)
                w(1) = a(i, 1): w(2) = a(i, 2): w(4) = a(i, 3)
            End If
            .Item(txt) = w
        Next
        x = .items: y = .Count
    End With
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Résultat").Delete
    On Error GoTo 0
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Résultat"
    With Sheets("Résultat").Cells(1)
        .Resize(1, 4).Value = Array("Clients", "Code", "2014", "2015")
        .Offset(1).Resize(y, 4).Value = _
        Application.Transpose(Application.Transpose(x))
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 38
            End With
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour,

Sub fusion()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("Données A")
  a = f1.Range("A2:C" & f1.[a65000].End(xlUp).Row)
  Set f2 = Sheets("Données B")
  b = f2.Range("A2:C" & f2.[a65000].End(xlUp).Row)
  n = UBound(a) + UBound(b)
  Dim c: ReDim c(1 To n, 1 To 4)
  m = 0
  For i = LBound(a) To UBound(a)
    If Not d1.exists(a(i, 1) & a(i, 2)) Then m = m + 1: d1(a(i, 1) & a(i, 2)) = m: p = m Else p = d1(a(i, 1) & a(i, 2))
    c(p, 1) = a(i, 1): c(p, 2) = a(i, 2): c(p, 3) = a(i, 3)
  Next i
  For i = LBound(b) To UBound(b)
    If Not d1.exists(b(i, 1) & b(i, 2)) Then m = m + 1: d1(b(i, 1) & b(i, 2)) = m: p = m Else p = d1(b(i, 1) & b(i, 2))
    c(p, 1) = b(i, 1): c(p, 2) = b(i, 2): c(p, 4) = b(i, 3)
  Next i
  Set f3 = Sheets("Fusion")
  f3.[A2].Resize(d1.Count, UBound(c, 2)) = c
  f3.[A2].Resize(d1.Count, UBound(c, 2)).Sort key1:=f3.[A2], Header:=xlNo
  f1.[a1:c1].Copy f3.[A1]: f2.[c1].Copy f3.[d1]
End Sub

Ceuzin