Sub Colonner()
Dim ws As Worksheet, wsDest As Worksheet
Dim Valeurs As Variant, Colonnes As Variant
Dim ligne As Long
Dim idx As Variant
Dim i As Integer
Dim nomCol As String
With ThisWorkbook
'Destination des données
' Nettoyer
Set wsDest = .Sheets("Fusion_3_BDD")
ligne = wsDest.Cells(Rows.Count, 1).End(xlUp).Row
If ligne > 2 Then wsDest.Range("A2:A" & ligne).ClearContents
'
'
' Import des données
For i = 0 To 2
Set ws = .Sheets(Array("BDD1", "BDD2", "BDD3")(i))
With ws.Range(Array("B1", "C1", "D1")(i)).ListObject
nomCol = ws.Range(Array("B1", "C1", "D1")(i))
idx = Application.Match(nomCol, .HeaderRowRange, 0)
If Not IsError(idx) Then Valeurs = .ListColumns(idx).DataBodyRange
If IsArray(Valeurs) Then
wsDest.Cells(Rows.Count, 1).End(xlUp)(2).Resize(UBound(Valeurs)).Value = Valeurs
End If
End With
Next
End With
With wsDest
'
' Dernière ligne de donnée de la colonne A
ligne = .Cells(Rows.Count, 1).End(xlUp).Row
'
' Entêter B1
.Range("B1") = "nbr"
'
' Mettre formule de comptage en colonne B
With .Range("B2:B" & ligne)
.Formula = "=COUNTIF($A$2:$A$" & ligne & ",$A2)"
.Value = .Value
End With
'
'Trier sur colonne B en ordre descendant
.Range("A1").CurrentRegion.Sort .Range("B2"), xlDescending
'
' Sur de très long tableau
' il peut y avoir un temps de latence pour le calcul de la feuille
' Attendre l'application
Do
DoEvents
Loop Until Application.CalculationState = xlDone
'
' Chercher la première valeurs = 1 dans colonne b
idx = Application.Match(1, .Columns(2), 0)
'
' Si trouvé supprimer toutes les autres lignes
If Not IsError(idx) Then .Range("A2:B" & idx).Rows.Delete xlShiftUp
'
' Supprimer les données de colonne B
.Range("B1:B" & ligne).ClearContents
End With
End Sub