Fusion de deux listes

Sub Bouton1_QuandClic()
Dim tablo1, tablo2, tabloS(1 To 2), tablores()
Dim present As Boolean, vide As Boolean
Dim n As Byte, i As Byte, j As Byte, k As Byte, l As Byte, m As Byte
Dim x As Byte

tablo1 = Sheets('liste1').Range('a1').CurrentRegion
tablo2 = Sheets('liste2').Range('a1').CurrentRegion
tabloS(1) = tablo1
tabloS(2) = tablo2

n = UBound(tablo1, 2) + UBound(tablo2, 2)
vide = True

For i = 1 To 2
        For j = 2 To UBound(tabloS(i))
                present = False
                If vide = True Then
                        ReDim Preserve tablores(1 To n, 1 To 1)
                        For k = 1 To UBound(tabloS(i), 2)
                                tablores(k, 1) = tabloS(i)(j, k)
                        Next k
                        vide = False
                Else
                        For k = 1 To UBound(tablores, 2)
                                If tablores(1, k) = tabloS(i)(j, 1) Then
                                        present = True
                                        For l = 1 To UBound(tablores, 1)
                                                If tablores(l, k) = '' Then Exit For
                                        Next l
                                        For m = 2 To UBound(tabloS(i), 2)
                                                tablores(m + l - 2, k) = tabloS(i)(j, m)
                                        Next m
                                End If
                        Next k
                        If Not present Then
                                x = UBound(tablores, 2) + 1
                                ReDim Preserve tablores(1 To n, 1 To x)
                                For k = 1 To UBound(tabloS(i), 2)
                                        tablores(k, x) = tabloS(i)(j, k)
                                Next k
                        End If
                End If
        Next j
Next i

Sheets('synthese').Range('a1').Resize(UBound(tablores, 2), UBound(tablores, 1)) = Application.Transpose(tablores)
End Sub

Cliquez pour agrandir...