Sub Regroupe()
Application.ScreenUpdating = False
Set f1 = Sheets("DU")
f1.Range("A14:H65536").ClearContents
n = 14
For i = 1 To 14
With Worksheets(i)
For j = 8 To .Cells(65536, 1).End(xlUp).Row
If .Cells(j, 24).Value = "inacceptable" Or .Cells(j, 24).Value = "tolerable" Then
f1.Cells(n, 1) = .Cells(j, 1)
f1.Cells(n, 2) = .Cells(j, 2)
f1.Cells(n, 3) = .Cells(j, 6)
f1.Cells(n, 4) = .Cells(j, 9)
f1.Cells(n, 5) = .Cells(j, 11)
f1.Cells(n, 6) = .Cells(j, 24)
f1.Cells(n, 7) = .Cells(j, 26)
f1.Cells(n, 8) = .Cells(j, 37)
n = n + 1
End If
Next j
End With
Next i
End Sub