Option Compare Text 'la casse est ignorée
Private Sub Worksheet_Activate()
Dim col%, nlig&, ncol%, t, s$, i&, x$, j&, n&
col = 2 'n° de colonne des montants, à adapter
With Feuil1.[A1].CurrentRegion 'à adapter
nlig = .Rows.Count
ncol = .Columns.Count + 1 ' avec colonne auxiliaire
t = .Resize(, ncol) 'matrice, plus rapide
End With
'---repérage des paires opposées---
s = Chr(1) 'séparateur
For i = 2 To nlig
If IsNumeric(t(i, col)) And t(i, ncol) = "" Then
x = t(i, 1) & s & -t(i, col)
For j = i + 1 To nlig
If x = t(j, 1) & s & t(j, col) Then
t(i, ncol) = 1 'repérage
t(j, ncol) = 1 'repérage
Exit For
End If
Next j
End If
Next i
'---élimination des lignes repérées---
For i = 1 To nlig
If t(i, ncol) = "" Then
n = n + 1
For j = 1 To ncol - 1
t(n, j) = t(i, j)
Next j
End If
Next i
'---restitution---
[A1].Resize(n, ncol - 1) = t
[A1].Offset(n).Resize(Rows.Count - n, ncol - 1).ClearContents
End Sub
Option Explicit
Sub test()
Dim a, i As Long, txt As String, x As Range, e
With Sheets("Feuil1").Cells(1).CurrentRegion
.EntireRow.Interior.ColorIndex = xlNone
a = .Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
'colonne D
If a(i, 4) > 0 Then
'txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))'colonnes A et B
txt = a(i, 1) 'colonne A
If Not .exists(txt) Then
Set .Item(txt) = CreateObject("Scripting.Dictionary")
End If
.Item(txt)(i) = a(i, 4)
End If
Next
For i = 2 To UBound(a, 1)
'colonne D
If a(i, 4) < 0 Then
'txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))'colonnes A et B
txt = a(i, 1) 'colonne A
If .exists(txt) Then
For Each e In .Item(txt).keys
If a(i, 4) + .Item(txt)(e) = 0 Then
If x Is Nothing Then
Set x = Union(Rows(i), Rows(e))
Else
Set x = Union(x, Rows(e), Rows(i))
End If
.Item(txt).Remove e: Exit For
End If
Next
End If
End If
Next
End With
'If Not x Is Nothing Then x.EntireRow.Delete 'supprime
'colorie
If Not x Is Nothing Then x.EntireRow.Interior.ColorIndex = 42
End With
End Sub
Private Sub Worksheet_Activate()
Dim col%, nlig&, ncol%, t, i&, s$, x$, v, j&
col = 6 'n° de colonne des montants, à adapter
Application.ScreenUpdating = False
With Feuil1.[A1].CurrentRegion 'à adapter
nlig = .Rows.Count
ncol = .Columns.Count + 2 '2 colonnes auxiliaires
Cells.ClearContents 'RAZ
[A1].Resize(nlig, ncol - 2) = .Value 'copie des valeurs
End With
With [A1].Resize(nlig, ncol)
t = .Value
'---préparation---
For i = 1 To nlig
t(i, ncol) = i 'n° d'ordre
If t(i, col) < 0 Then t(i, ncol - 1) = -t(i, col) _
Else t(i, ncol - 1) = t(i, col) 'valeur absolue
Next i
.Value = t
.Sort .Columns(1), , .Columns(ncol - 1), , xlAscending, Header:=xlYes '1er tri
t = .Value
'---repérage des paires par effacement du n° d'ordre---
s = Chr(1)
For i = 2 To nlig
If t(i, ncol) = "" Then GoTo 1
x = t(i, 1) & s & t(i, ncol - 1)
v = t(i, col)
For j = i + 1 To nlig
If x <> t(j, 1) & s & t(j, ncol - 1) Then GoTo 1
If v <> t(j, col) And t(j, ncol) <> "" Then _
t(i, ncol) = "": t(j, ncol) = "": GoTo 1 'repérage
Next j
1 Next i
.Value = t
.Sort .Columns(ncol), xlAscending '2ème tri
'---suppression des paires---
On Error Resume Next
.Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'---suppression des colonnes auxiliaires---
.Columns(ncol - 1).Resize(, 2).Delete
End With
With Me.UsedRange: End With 'actualisation des barres de défilement
End Sub
Sub Journal()
'se lance par Ctrl+A
Dim col%, F1 As Worksheet, F2 As Worksheet, nlig&, ncol%, t, i&, s$, x$, v, j&
col = 6 'n° de colonne des montants, à adapter
Set F1 = Sheets("Journal") 'nom à adapter
Set F2 = Sheets("Supprimé") 'nom à adapter
Application.ScreenUpdating = False
F1.Rows("2:" & F1.Rows.Count).Delete 'RAZ
F2.Rows("2:" & F2.Rows.Count).Delete 'RAZ
With [A1].CurrentRegion
nlig = .Rows.Count
ncol = .Columns.Count + 2 '2 colonnes auxiliaires
F1.[A1].Resize(nlig, ncol - 2) = .Value 'copie des valeurs
End With
With F1.[A1].Resize(nlig, ncol)
t = .Value
'---préparation---
For i = 1 To nlig
t(i, ncol) = i 'n° d'ordre
If t(i, col) < 0 Then t(i, ncol - 1) = -t(i, col) _
Else t(i, ncol - 1) = t(i, col) 'valeur absolue
Next i
.Value = t
.Sort .Columns(1), , .Columns(ncol - 1), , xlAscending, Header:=xlYes '1er tri
t = .Value
'---repérage des paires par effacement du n° d'ordre---
s = Chr(1)
For i = 2 To nlig
If t(i, ncol) = "" Then GoTo 1
x = t(i, 1) & s & t(i, ncol - 1)
v = t(i, col)
For j = i + 1 To nlig
If x <> t(j, 1) & s & t(j, ncol - 1) Then GoTo 1
If v <> t(j, col) And t(j, ncol) <> "" Then _
t(i, ncol) = "": t(j, ncol) = "": GoTo 1 'repérage
Next j
1 Next i
.Value = t
.Sort .Columns(ncol), xlAscending '2ème tri
'---copie et suppression des paires---
On Error Resume Next
With .Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow
F2.[A2].Resize(.Rows.Count, ncol - 2) = .Resize(, ncol - 2).Value 'copie des valeurs
.Delete
End With
'---suppression des colonnes auxiliaires---
.Columns(ncol - 1).Resize(, 2).Delete
End With
'---actualisation des barres de défilement---
With F1.UsedRange: End With: With F2.UsedRange: End With
MsgBox "Les feuilles '" & F1.Name & "' et '" & F2.Name & "' ont été mises à jour"
End Sub
Sub Journal()
'se lance par Ctrl+A
Dim col%, F1 As Worksheet, F2 As Worksheet, nlig&, ncol%
Dim colaux1%, colaux2%, t, i&, lig&, neg&, pos&, n&
col = 6 'n° de colonne des montants, à adapter
Set F1 = Sheets("Journal") 'nom à adapter
Set F2 = Sheets("Supprimé") 'nom à adapter
Application.ScreenUpdating = False
F1.Rows("2:" & F1.Rows.Count).Delete 'RAZ
F2.Rows("2:" & F2.Rows.Count).Delete 'RAZ
With [A1].CurrentRegion
nlig = .Rows.Count
ncol = .Columns.Count + 3 '3 colonnes auxiliaires
colaux1 = ncol - 2: colaux2 = ncol - 1
F1.[A1].Resize(nlig, ncol - 3) = .Value 'copie des valeurs
End With
With F1.[A1].Resize(nlig, ncol)
t = .Value
'---préparation---
For i = 1 To nlig
t(i, ncol) = i 'n° d'ordre
If t(i, col) < 0 Then t(i, colaux1) = -t(i, col) _
Else t(i, colaux1) = t(i, col) 'valeur absolue
Next i
.Value = t
.Sort .Columns(1), , .Columns(colaux1), Header:=xlYes '1er tri
t = .Value
'---comptage des négatifs et positifs---
lig = 1
For i = 2 To nlig
If t(i, 1) <> t(i - 1, 1) Or t(i, colaux1) <> t(i - 1, colaux1) Then
t(lig, colaux2) = IIf(neg < pos, neg, pos)
lig = i: neg = 0: pos = 0
End If
If t(i, col) < 0 Then neg = neg + 1 Else pos = pos + 1
Next i
t(lig, colaux2) = IIf(neg < pos, neg, pos)
'---repérage des paires par effacement du n° d'ordre---
For i = 2 To nlig
If t(i, colaux2) Then n = t(i, colaux2): neg = 0: pos = 0
If t(i, col) < 0 Then
If neg < n Then t(i, ncol) = "": neg = neg + 1
Else
If pos < n Then t(i, ncol) = "": pos = pos + 1
End If
Next i
.Value = t
.Sort .Columns(ncol), xlAscending '2ème tri
'---copie et suppression des paires---
On Error Resume Next
With .Columns(ncol).SpecialCells(xlCellTypeBlanks).EntireRow
F2.[A2].Resize(.Rows.Count, ncol - 3) = .Resize(, ncol - 3).Value 'copie des valeurs
.Delete
End With
'---suppression des colonnes auxiliaires---
.Columns(colaux1).Resize(, 3).Delete
End With
'---actualisation des barres de défilement---
With F1.UsedRange: End With: With F2.UsedRange: End With
MsgBox "Les feuilles '" & F1.Name & "' et '" & F2.Name & "' ont été mises à jour"
End Sub
J'attends la version (10)... Qui prendra 0.0001 seconde... Pour engranger dans mon grenier.
Sub Journal()
'se lance par Ctrl+A
Dim col%, F1 As Worksheet, F2 As Worksheet, nlig&, ncol%, colaux%, t
Dim dneg As Object, dpos As Object, s$, i&, x$, dneg1 As Object, dpos1 As Object, n&
col = 6 'n° de colonne des montants, à adapter
Set F1 = Sheets("Journal") 'nom à adapter
Set F2 = Sheets("Supprimé") 'nom à adapter
Application.ScreenUpdating = False
F1.Rows("2:" & F1.Rows.Count).Delete 'RAZ
F2.Rows("2:" & F2.Rows.Count).Delete 'RAZ
With [A1].CurrentRegion
nlig = .Rows.Count
ncol = .Columns.Count + 2 '2 colonnes auxiliaires
colaux = ncol - 1
F1.[A1].Resize(nlig, ncol - 2) = .Value 'copie des valeurs
End With
With F1.[A1].Resize(nlig, ncol)
t = .Value
'---comptage des négatifs et positifs---
Set dneg = CreateObject("Scripting.Dictionary")
Set dpos = CreateObject("Scripting.Dictionary")
s = Chr(1)
For i = 1 To nlig
x = t(i, 1) & s & Replace(t(i, col), "-", "")
t(i, ncol) = x 'mémorisation
If t(i, col) < 0 Then dneg(x) = dneg(x) + 1 Else dpos(x) = dpos(x) + 1
Next i
'---repérage des non-paires---
Set dneg1 = CreateObject("Scripting.Dictionary")
Set dpos1 = CreateObject("Scripting.Dictionary")
For i = 1 To nlig
x = t(i, ncol)
n = IIf(dneg(x) < dpos(x), dneg(x), dpos(x))
If t(i, col) < 0 Then
If dneg1(x) < n Then dneg1(x) = dneg1(x) + 1 Else t(i, colaux) = 1 'repérage
Else
If dpos1(x) < n Then dpos1(x) = dpos1(x) + 1 Else t(i, colaux) = 1 'repérage
End If
Next i
.Columns(colaux) = Application.Index(t, , colaux)
.Resize(, colaux).Sort .Columns(colaux) 'tri
'---copie et suppression des paires---
On Error Resume Next
With .Columns(colaux).SpecialCells(xlCellTypeBlanks).EntireRow
F2.[A2].Resize(.Rows.Count, ncol - 2) = .Resize(, ncol - 2).Value 'copie des valeurs
.Delete
End With
'---suppression de la colonne auxiliaire---
.Columns(colaux).Delete
End With
'---actualisation des barres de défilement---
With F1.UsedRange: End With: With F2.UsedRange: End With
MsgBox "Les feuilles '" & F1.Name & "' et '" & F2.Name & "' ont été mises à jour"
End Sub