Private Sub Worksheet_Calculate()
Dim P As Range, derlig&, n As Byte
Dim i&, P1 As Range, s As Range
Application.ScreenUpdating = False
1 Set P = Range([Table1], [Table2])
derlig = P.Row + P.Rows.Count - 1
n = n + 1
If Me.AutoFilterMode Then n = _
IIf(Intersect(AutoFilter.Range, [Table1]) Is Nothing, 1, 2)
Set P = Range("table" & n)
With Workbooks.Add.Sheets(1) 'nouveau document
'---copie du tableau ligne par ligne---
i = 1
While P.Rows(i).Row <= derlig
If P.Rows(i).EntireRow.Hidden Then .Cells(i, 1) = 1
If i <= P.Rows.Count Then P.Rows(i).Copy .Cells(i, 2)
i = i + 1
Wend
Set P1 = Intersect(.[B:IV], .UsedRange)
End With
'---suppression des lignes vides---
Set s = Nothing
For i = 1 To P1.Rows.Count
If Application.CountA(P1.Rows(i)) = 0 Then _
Set s = Union(P1.Rows(i), IIf(s Is Nothing, P1.Rows(i), s))
Next
If Not s Is Nothing Then s.Delete xlUp
'---insertion de lignes---
2 For i = 1 To P1.Rows.Count
If P1(i, 0) * Application.CountA(P1.Rows(i)) Then
P1.Rows(i).Insert xlDown
If i = 1 Then Set P1 = P1.Parent.Range(P1(0, 1), P1)
GoTo 2
End If
Next
'---nouveau tableau---
Application.EnableEvents = False
P.Clear
P1.Copy P(1, 1)
P(1, 1).Resize(P1.Rows.Count, P1.Columns.Count).Name = "Table" & n
P1.Parent.Parent.Close False 'fermeture du nouveau document
If Not Me.AutoFilterMode And n = 1 Then GoTo 1
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
