Private Sub Worksheet_Activate()
Dim r As Range, tablo1(), n1 As Long, tablo2(), n2 As Long
Set r = Sheets("Base").Range("A:A,E:E,I:I").SpecialCells(xlCellTypeConstants)
For Each r In r
If r.Font.Bold Then 'si gras
ReDim Preserve tablo1(1, n1) 'tableau transposé
tablo1(0, n1) = r
tablo1(1, n1) = r.Offset(, 1)
n1 = n1 + 1
Else
ReDim Preserve tablo2(1, n2) 'tableau transposé
tablo2(0, n2) = r
tablo2(1, n2) = r.Offset(, 1)
n2 = n2 + 1
End If
Next
Application.ScreenUpdating = False
Me.[A2:D65536].ClearContents 'RAZ
If n1 Then Me.[A2:B2].Resize(n1) = Application.Transpose(tablo1)
If n2 Then Me.[C2:D2].Resize(n2) = Application.Transpose(tablo2)
End Sub