Salut,
Merci mille fois, j'ai pu arriver a mes fins.
Ci-dessous la dernière version du code.
J'ai utilisé une fonction de tri par bulles et fais quelques modifs sur les fonction princ et recherche pour faire tourner la macro sans faille.
J'ai aussi rajouté une colonne avant D en recopiant la date pour afficher le jour.
Tout cela m'a permis de bien comprendre la macro que tu avais envoyée.
La base de tout.
Vraiment génial...
A+++
Bonne année.
'**************************************
Option Explicit
Const Plage As String = "O2:T65536"
Const NomF1 As String = "Service"
Const NomF2 As String = "matchs"
Const PlageDef As String = "NomPrénom"
Const PlageNom As String = "Nom"
Const PlagePrénom As String = "Prénom"
'feuille matchs
Const ColDate As Byte = 1
Const ColHor As Byte = 3
Const ColDom As Byte = 8
Const ColArb1 As Byte = 15
Const ColArb2 As Byte = 16
Const ColChrono As Byte = 17
Const ColMarq As Byte = 18
Const ColSalle As Byte = 19
Const ColBuv As Byte = 20
Const ColCat As Byte = 22
'**************************************
Sub Princ()
Dim T, T1, TN, TP, i As Long, Ligne As Long, j, k As Long
T1 = Range(PlageDef).Value
TN = Range(PlageNom).Value
TP = Range(PlagePrénom).Value
Worksheets(NomF1).Range("B4:K65536").ClearContents
Worksheets(NomF1).Rows.PageBreak = xlNone
For i = LBound(T1) To UBound(T1)
If Len(T1(i, 1)) > 0 Then
T = Recherche(Worksheets(NomF2).Range(Plage), T1(i, 1))
If IsArray(T) Then
With Worksheets(NomF1)
Ligne = .[D65536].End(xlUp).Row + 1
.Range("B" & Ligne) = TN(i, 1)
.Range("C" & Ligne) = TP(i, 1)
For j = LBound(T, 2) To UBound(T, 2)
If j > 0 And j < UBound(T, 2) Then
If (T(0, j) = T(0, j - 1) And T(1, j) = T(1, j - 1)) Then
Ligne = Ligne - 1
End If
End If
.Range("D" & Ligne) = T(0, j)
.Range("E" & Ligne) = T(0, j)
.Range("F" & Ligne) = T(1, j)
.Range("G" & Ligne) = T(2, j)
Select Case T(3, j)
Case ColArb1, ColArb2: .Range("H" & Ligne) = "X"
Case ColChrono: .Range("I" & Ligne) = "X"
Case ColMarq: .Range("J" & Ligne) = "X"
Case ColSalle, ColBuv: .Range("K" & Ligne) = "X"
End Select
Ligne = Ligne + 1
Next j
End With
Worksheets(NomF1).Rows(Ligne - 1).PageBreak = xlPageBreakManual
End If
Worksheets(NomF1).PageSetup.PrintArea = "A1:K" & Ligne - 2 & ""
End If
Next i
End Sub
'**************************************
Private Function Recherche(P As Range, Valeur)
Dim C As Range, T, Adresse1 As String, i As Long, T2
i = 0
With P
Set C = .Find(Valeur, , xlValues)
If Not C Is Nothing Then
ReDim T(3, i)
ReDim T2(3, i)
Adresse1 = C.Address
Do
With C
'Test peut être inutile
' If .Offset(0, ColDom - .Column) = "Domicile" Then
T(0, i) = VBA.Format(.Offset(0, ColDate - .Column).Text, "mm/dd/yy") 'date
T(1, i) = .Offset(0, ColHor - .Column).Text 'Horaire
T(2, i) = .Offset(0, ColCat - .Column).Text 'Categorie
T(3, i) = .Column
T2(0, i) = .Offset(0, ColDate - .Column) ' Date numerique
T2(1, i) = .Offset(0, ColDate - .Column) ' Horaire numerique
i = i + 1
ReDim Preserve T(3, i)
ReDim Preserve T2(3, i)
' End If
End With
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> Adresse1
End If
End With
T = Triertable(T, i, T2)
Recherche = T
End Function
'**************************************
Sub Bouton8_QuandClic()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Princ
End Sub
'**************************************
Function Triertable(T, Maxi As Long, T2)
Dim i, j As Long, tmpstr As String, tmpnum
If Maxi > 1 Then
For i = Maxi - 1 To 0
For j = 0 To i
If T2(0, j + 1) & T2(1, j + 1) < T2(0, j) & T2(1, j) Then
tmpnum = T2(0, j)
T2(0, j) = T2(0, j + 1)
T2(0, j + 1) = tmpnum
tmpnum = T2(1, j)
T2(1, j) = T2(1, j + 1)
T2(1, j + 1) = tmpnum
tmpstr = T(0, j)
T(0, j) = T(0, j + 1)
T(0, j + 1) = tmpstr
tmpstr = T(1, j)
T(1, j) = T(1, j + 1)
T(1, j + 1) = tmpstr
tmpstr = T(2, j)
T(2, j) = T(2, j + 1)
T(2, j + 1) = tmpstr
tmpstr = T(3, j)
T(3, j) = T(3, j + 1)
T(3, j + 1) = tmpstr
End If
Next j
Next i
End If
Triertable = T
End Function
'**************************************