[COLOR="DarkSlateGray"][B]Sub Nettoyer()
nettoyer_tableau_sans_clef sSh1:=Worksheets("Feuil1"), sSh2:=Worksheets("Feuil2")
End Sub
Private Sub nettoyer_tableau_sans_clef(sSh1 As Object, sSh2 As Object, Optional lT1 As Long = 1, Optional lT2 As Long = 1)
[COLOR="SeaGreen"]'
' La procédure supprime les lignes de la feuille sSh1 qui ont un contenu identique à celui de l'une des _
lignes de la feuille sSh2 sous les conditions suivantes : _
- Les lignes d'entête des champs sont les lignes lT1 de sSh1 et lT2 de sSh2. _
Les paramètres lT1 et lT2 sont optionnels (valeur par défaut : 1). _
- Les colonnes prises en compte dans la comparaison sont celles qui ont le même entête.
'
' Les tableaux peuvent comporter des lignes et des colomnes vides.
' L'ordre des champs peut être différent dans les deux feuilles.
'[/COLOR]
Dim oB1, oB2, oC, i As Long, j As Long, nTmp As Long, sTmp As String
lT1 = lT1 - 1: lT2 = lT2 - 1
[COLOR="SeaGreen"]'
' Sélection des lignes d'entête.[/COLOR]
With sSh1
oB1 = .[A1].Offset(lT1, 0).Resize(1, .[A1].Offset(lT1, 0).Offset(0, .Columns.Count - 1).End(xlToLeft).Column).Value
End With
With sSh2
oB2 = .[A1].Offset(lT2, 0).Resize(1, .[A1].Offset(lT2, 0).Offset(0, .Columns.Count - 1).End(xlToLeft).Column).Value
End With
If IsEmpty(oB1) Or IsEmpty(oB2) Then Exit Sub 'Il n'y a pas de champ commun aux deux feuilles.
[COLOR="SeaGreen"]'
' Correspondance des champs d'une feuille à l'autre.[/COLOR]
oC = Array(Array(0, 0))
nTmp = UBound(oB2, 2)
With WorksheetFunction
For i = 1 To UBound(oB1, 2)
sTmp = oB1(1, i)
For j = 1 To nTmp
If oB2(1, j) = sTmp Then
ReDim Preserve oC(UBound(oC) + 1)
oC(UBound(oC)) = oC(0)
oC(UBound(oC))(0) = i
oC(UBound(oC))(1) = j
oC(0)(0) = .Max(i, oC(0)(0))
oC(0)(1) = .Max(j, oC(0)(1))
End If
Next j
Next i
End With
[COLOR="SeaGreen"]'
' Sélection des données à traiter.[/COLOR]
With sSh1.[A1].Offset(lT1, 0)
oB1 = Intersect(.Resize(sSh1.Rows.Count - lT1 - 1, .Offset(0, oC(0)(0)).Column - 1), sSh1.Range(.Cells, .SpecialCells(xlLastCell))).Value
End With
With sSh2.[A1].Offset(lT2, 0)
oB2 = Intersect(.Resize(sSh2.Rows.Count - lT2 - 1, .Offset(0, oC(0)(0)).Column - 1), sSh2.Range(.Cells, .SpecialCells(xlLastCell))).Value
End With
[COLOR="SeaGreen"]'
' Concaténation des champs sélectionnés.[/COLOR]
nTmp = UBound(oC)
For i = 2 To UBound(oB1, 1)
sTmp = ""
For j = 2 To nTmp
sTmp = sTmp & oB1(i, oC(j)(0)) & "#"
Next j
oB1(i, 1) = sTmp
Next i
ReDim Preserve oB1(1 To UBound(oB1, 1), 1 To 1)
For i = 2 To UBound(oB2, 1)
sTmp = ""
For j = 2 To nTmp
sTmp = sTmp & oB2(i, oC(j)(1)) & "#"
Next j
oB2(i, 1) = sTmp
Next i
ReDim Preserve oB2(1 To UBound(oB2, 1), 1 To 1)
[COLOR="SeaGreen"]'
' Comparaison des feuilles ligne à ligne et suppression des lignes communes dans sSh1.[/COLOR]
nTmp = UBound(oB2, 1)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With sSh1
For i = UBound(oB1, 1) To 2 Step -1
sTmp = oB1(i, 1)
For j = 1 To nTmp
If oB2(j, 1) = sTmp Then .Rows(i + lT1).Delete xlShiftUp
Next j
Next i
End With
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub[/B][/COLOR]
