Option Compare Text 'la casse est ignorée
Private Sub Worksheet_Activate()
Dim nom As Range, nlig&, P As Range, Q As Range, j%, memP, memQ, a, b, jour As Range, n%, i&, x$, k%
Set nom = Sheets(" a").[A7:A38] 'bah il y a un espace avant le a...
nlig = nom.Rows.Count
Set P = [F21:J35]
Set Q = [M21:M35]
Application.ScreenUpdating = False
For j = 0 To 30
memP = P: memQ = Q 'mémorise les données des 2 tableaux
P = "": Q = "" 'RAZ
a = P: b = Q 'matrices, plus rapides
Set jour = nom.Offset(, 4 + j)
n = 0
For i = 1 To nlig
x = jour(i)
If x = "x" Or x = "m" Or x = "am" Then
n = n + 1
If n > 15 Then MsgBox "Le " & Format(jour(-1), "dd/mm/yyyy") & " plus de 15 cellules sont renseignées !", 48: Exit For
If x = "x" Or x = "m" Then a(n, 2) = nom(i) & " " & nom(i, 2)
If x = "x" Or x = "am" Then a(n, 4) = nom(i) & " " & nom(i, 2)
x = a(n, 2) & Chr(1) & a(n, 4) 'texte concaténé à rechercher
For k = 1 To 15
If memP(k, 2) & Chr(1) & memP(k, 4) = x Then 'restitue les valeurs mémorisées
a(n, 1) = memP(k, 1)
a(n, 3) = memP(k, 3)
a(n, 5) = memP(k, 5)
b(n, 1) = memQ(k, 1)
Exit For
End If
Next k
End If
Next i
'---restitution---
If n Then
P.Resize(n) = a
Q.Resize(n) = b
End If
'---nouveaux tableaux---
Set P = P.Offset(20)
Set Q = Q.Offset(20)
Next j
End Sub