Sub Transfert()
Dim ncol%, Sh As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, ShDest As Worksheet, tablo, resu(), i&, n&, j%, nn&
ncol = 20 'nombre de colonnes
Set Sh = ActiveSheet
Set Sh1 = Sheets("Situation ") 'pourquoi un espace ???
Set Sh2 = Sheets("Entrepôt")
If Sh.Name = Sh1.Name Then Set ShDest = Sh2
If Sh.Name = Sh2.Name Then Set ShDest = Sh1
If ShDest Is Nothing Then Exit Sub
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
With Sh.Range("B5:B" & Sh.Range("E" & Sh.Rows.Count).End(xlUp).Row).Resize(, ncol)
If .Row < 5 Then Exit Sub 'si le tableau est vide
tablo = .FormulaR1C1 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncol)
For i = 1 To UBound(tablo)
If tablo(i, 2) = 0 Then 'critère 0 en colonne C
n = n + 1
For j = 1 To ncol
tablo(n, j) = tablo(i, j)
Next j
Else
nn = nn + 1
For j = 1 To ncol
resu(nn, j) = tablo(i, j)
Next j
End If
Next i
'---restitution en 1ère feuille---
Application.ScreenUpdating = False
.Borders.LineStyle = xlNone 'efface toute bordure
If nn Then
.Resize(nn).FormulaR1C1 = resu
.Resize(nn).BorderAround Weight:=xlMedium 'pourtour
.Borders(xlEdgeTop).LineStyle = xlNone
End If
If nn < .Rows.Count Then
With .Rows(nn + 1).Resize(.Rows.Count - nn)
.ClearContents 'RAZ sous le tableau
.Interior.ColorIndex = xlNone 'efface les couleurs
.Columns(2).Validation.Delete
End With
End If
End With
'---restitution en 2ème feuille---
If ShDest.FilterMode Then ShDest.ShowAllData 'si la feuille est filtrée
i = ShDest.Range("E" & ShDest.Rows.Count).End(xlUp).Row + 1
If n Then
With ShDest.Cells(i, 2).Resize(n, ncol)
.FormulaR1C1 = tablo
.BorderAround Weight:=xlMedium 'pourtour
.Borders(xlEdgeTop).LineStyle = xlNone
.Columns(2).Validation.Delete
.Columns(2).Validation.Add xlValidateList, Formula1:="0,1"
With Union(.Columns(7), .Columns(11), .Columns(15), .Columns(19), .Columns(20))
.Interior.Color = .Cells(0, 1).Interior.Color 'fond gris
.Font.Bold = True 'gras
.Font.Color = vbBlack 'police noire
.HorizontalAlignment = xlCenter 'centrage
End With
.Columns(20).Font.Color = vbWhite 'police blanche
End With
Application.Goto ShDest.Cells(i, 2) 'facultatif
End If
End Sub