Filtrer un tableau et figer le deuxième d'un même onglet

FranQuent

XLDnaute Nouveau
Bonjour,

Voici un code qui permet de copier un tableau "Table2" pendant qu'on filtre le tableau "Table1".

Option Explicit

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 = .Range("B1", Intersect(.[B:IV], .UsedRange))
End With
'---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
Cependant la copie ne prend pas les formules et met des "#REF!" à la place.
Voyez-vous une solution?

Merci
 

Discussions similaires


Haut Bas