Re : Un calcul avec des tri et compare ...
Ci dessous la Macro a modifier avec les info du Post precedent
Sub AMALGAME()
tridecroissant
EffacerColonneC
TrierListe
ChercherDoublons
copiecoll
tricroissant
End Sub
Sub tridecroissant()
Range("I1").Select
Selection.Sort Key1:=Range("I1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Sub EffacerColonneC()
Dim L As Integer
L = Sheets("BRODARD").Range("C65536").End(xlUp).Row
Sheets("BRODARD").Select
If L + 1 = 2 Then Exit Sub
Range("C2:C" & L).Select
Selection.ClearContents
End Sub
Sub TrierListe()
Dim L As Integer
L = Sheets("BRODARD").Range("A65536").End(xlUp).Row
Sheets("BRODARD").Select
Range("C2:J" & L).Select
'Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Sub ChercherDoublons()
Dim L As Integer, i As Integer, j As Integer, Ws As Worksheet, a As Integer, k As Integer, m As Integer
Set Ws = Sheets("BRODARD")
a = 1
L = Ws.Range("A65536").End(xlUp).Row
'Trouver tout les doublons et les numeroter
For i = 2 To L
For j = i + 1 To L
If Ws.Range("I" & i) = Ws.Range("I" & j) And Ws.Range("C" & i) = "" _
And Ws.Range("E" & i) = 4 And Ws.Range("G" & i) = 70 And Ws.Range("E" & j) = 4 And _
Ws.Range("G" & j) = 70 Then
Ws.Range("C" & i) = "Amal " & a
Ws.Range("C" & j) = "Amal " & a
a = a + 1
End If
If Ws.Range("I" & i) = Ws.Range("I" & j) And Ws.Range("C" & i) = "" _
And Ws.Range("E" & i) = 4 And Ws.Range("G" & i) = 90 And Ws.Range("E" & j) = 4 And _
Ws.Range("G" & j) = 90 Then
Ws.Range("C" & i) = "Amal " & a
Ws.Range("C" & j) = "Amal " & a
a = a + 1
End If
Next
Next
'Trouver les amalgames qui ne sont pas des doublons
For k = 2 To L
For m = k + 1 To L
If Ws.Range("E" & k) = 4 And Ws.Range("G" & k) = 70 And Ws.Range("C" & k) = "" And _
Ws.Range("E" & m) = 4 And Ws.Range("G" & m) = 70 And Ws.Range("C" & m) = "" Then
Ws.Range("C" & k) = "Amal " & a
Ws.Range("C" & m) = "Amal " & a
a = a + 1
End If
If Ws.Range("E" & k) = 4 And Ws.Range("G" & k) = 90 And Ws.Range("C" & k) = "" And _
Ws.Range("E" & m) = 4 And Ws.Range("G" & m) = 90 And Ws.Range("C" & m) = "" Then
Ws.Range("C" & k) = "Amal " & a
Ws.Range("C" & m) = "Amal " & a
a = a + 1
End If
Next
Next
'Trouver et inscrire en face de chacun, le nombre le plus eleve de chaque amalgame
For n = 2 To L
If Ws.Range("C" & n) = "" Then GoTo C
For o = n + 1 To L
If Ws.Range("C" & o) = "" Then GoTo D
If Ws.Range("C" & n) = Ws.Range("C" & o) Then
Ws.Range("J" & n).Select
ActiveCell.Formula = "=MAX(I" & n & ",I" & o & ")"
Ws.Range("J" & o).Select
ActiveCell.Formula = "=MAX(I" & n & ",I" & o & ")"
End If
D:
Next
C:
Next
End Sub
Sub copiecoll()
Range("J2:J33").Select
Selection.Copy
Application.CutCopyMode = False
Range("J2").Select
ActiveSheet.Paste
Range("J33").Select
End Sub
Sub tricroissant()
Range("A1").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub