amelioration visuel

[joe]

bonjour a tous

SI une personne pouvait me resoudre mon soucie , afin que j evite les erreurs , dans un tableau essentiel a mon job
merci

 

[Zon]

Salut,

Colles ceci dans un module standard, testes pour vois si c'est cela que tu veux:

Sub ColorerDoublons2foiS()
Dim Plage As Range, T(), I&
Dim Debut, Fin
Application.ScreenUpdating = False
Set Plage = Range([D6], [E65536].End(xlUp)) ' à adapter
With Plage
ReDim T(1 To .Rows.Count)
For I = 1 To UBound(T)
T(I) = .Cells(I, 1) & " " & .Cells(I, 2)
Next I
For I = 1 To UBound(T)
If SomSI(T, T(I)) = 2 Then
.Cells(I, 5).Interior.ColorIndex = 4
End If
Next I
End With
End Sub
Function SomSI(T, Valeur) As Double
Dim I&
For I = LBound(T) To UBound(T)
If T(I) = Valeur Then SomSI = SomSI + 1
Next I
End Function

A+++

 

[omicron]

Bonjour Joe et Zon,

Voici en pièce jointe une petite variante sur le même thème ...

=====================================================
Private Sub CommandButton1_Click()

'Désactivation Affichage pendant déroulement Macro (Optimisation)
Application.ScreenUpdating = False

'Si la feuille "Save" existe, alors copie feuille "Save" dans feuille "Résultats", sinon rien
For Each Sht In Sheets
If Sht.Name = "Save" Then
Sht.Cells.Copy Destination:=Sheets("Résultats").Range("A1")
Exit For
End If
Next Sht

'Ajout d'un colonne 1 contenant les n° de ligne avant tri pour appareillage
Sheets("Résultats").Activate
ActiveSheet.Columns(1).Insert Shift:=xlToRight

Set RngTit = ActiveWorkbook.Names("Titre").RefersToRange
Set RngTbl = ActiveWorkbook.Names("Tableau").RefersToRange
Set RngWrk = ActiveSheet.Range("A1:" & RngTbl.Cells(RngTbl.Cells.Count).Address)

For Each Row In RngWrk.Rows
Row.Cells(1) = Row.Row
Next Row

'Tri sur les colonnes Jockey et Entraîneur pour détection des doubles
RngWrk.Sort Key1:=RngWrk.Columns("E").Rows(1), Order1:=xlAscending, Key2:=RngWrk.Columns("F").Rows(1), _
Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal

'Appareillage des lignes et coloriage des doublons sur Jockey et Entraineur
For Each Cel In RngWrk.Columns("E").Cells
If Cel <> "" And Cel.EntireRow.Cells(1) <> RngTit.Row Then
Sheets("Résultats").Range(Cel.Address & ":" & Cel.Offset(0, 1).Address).Interior.ColorIndex = _
ActiveWorkbook.Names("ColNo").RefersToRange.Interior.ColorIndex
If Cel.Row > 1 Then
If Cel = Cel.Offset(-1, 0) And Cel.Offset(0, 1) = Cel.Offset(-1, 1) Then _
Sheets("Résultats").Range(Cel.Offset(-1, 0).Address & ":" & Cel.Offset(0, 1).Address).Interior.ColorIndex = _
ActiveWorkbook.Names("ColYes").RefersToRange.Interior.ColorIndex
End If
End If
Next Cel

'Tri des lignes sur n° de ligne avant tri pour appareillage afin de rétablir l'ordre de départ
RngWrk.Sort Key1:=RngWrk.Columns("A").Rows(1), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'Suppression de la colonne n° de ligne avant tri pour appareillage
ActiveSheet.Columns(1).Delete Shift:=xlToLeft

'Réactivation Affichage
Application.ScreenUpdating = True

End Sub
=====================================================

Je pense que les manipulations sont suffisamment simple pour pouvoir se passer de plus d'explications que celles qui figurent dans le code.

En espérant avoir bien compris le problème ....

Cordialement.

Omicron.

 

[bono]

bonjour

comme je viens de rentrer je ne vous remercie que maintenant , veuillez m en excuse .
merci bien