Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Base de données.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
an = Application.InputBox("Entrez l'année :", "Transfert", an)
If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
For Each w In ThisWorkbook.Worksheets
If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
If derlig > 6 Then
tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
For i = 1 To UBound(tablo)
If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
n = n + 1
For j = 1 To ncol
resu(n, j) = tablo(i, j)
Next j
End If
End If
Next i
End If
Next w
'---restitution---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier).Sheets(1)
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[A2] 'adapter éventuellement
If n Then
.Resize(n, ncol) = resu
.Resize(n, ncol).Borders.Weight = xlThin 'bordures
.Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
End If
.Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
.Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
End With
With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub