Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'maintient 2 lignes vides avant les tableaux Archives
If Sh.ListObjects.Count < 2 Then Exit Sub
Dim derlig1&, derlig2&, derlig, cc%
derlig1 = Sh.ListObjects(1).Range.Row + Sh.ListObjects(1).Range.Rows.Count - 1
derlig2 = Sh.ListObjects(2).Range.Row + Sh.ListObjects(2).Range.Rows.Count - 1
derlig = IIf(derlig1 > derlig2, derlig1, derlig2)
Application.EnableEvents = False
Application.DisplayAlerts = False
derlig1 = Sh.Cells.SpecialCells(xlCellTypeLastCell).Row 'denière cellule de la feuille
If [Archives1].Row - derlig <> 3 Then
cc = Sh.ListObjects(1).Range.Columns.Count
[Archives1].Resize(derlig1 - [Archives1].Row + 1, cc).Cut Cells(derlig + 3, [Archives1].Column) 'couper-coller
[Archives1].Resize(, cc).Merge 'refusionne
End If
If [Archives2].Row - derlig <> 3 Then
cc = Sh.ListObjects(2).Range.Columns.Count
[Archives2].Resize(derlig1 - [Archives2].Row + 1, cc).Cut Cells(derlig + 3, [Archives2].Column) 'couper-coller
[Archives2].Resize(, cc).Merge 'refusionne
End If
Application.EnableEvents = True
End Sub
Sub Archiver()
If IsError(Application.Caller) Then Exit Sub
Dim n As Byte, col%, cc%, i&, r As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
n = IIf(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column >= ActiveSheet.ListObjects(2).Range.Column, 2, 1)
With ActiveSheet.ListObjects(n).Range
col = Range("Archives" & n).Column
cc = .Columns.Count
For i = .Rows.Count To 2 Step -1
If .Cells(i, 2) <> "" And (.Cells(i, 3) = "Terminé" Or n = 2) Then
Set r = Cells(Rows.Count, col).End(xlUp)(2).Resize(, cc)
.Rows(i).Copy r
r = r.Value 'supprime les formules
r.Interior.ColorIndex = xlNone
r.Borders.Weight = xlThin
r.Borders.ColorIndex = xlAutomatic
.Rows(i).Delete xlUp
End If
Next
End With
Application.EnableEvents = True
Workbook_SheetChange ActiveSheet, [A1] 'lance la macro
End Sub