Bonjour,
Je crois que j'ai réussi à intégrer l'extension automatique de la formule aux cellules adjacentes. Je vous ai corrigé le cas particulier d'une ligne seule pour renvoyer une ligne et non une colonne.
ATTENTION IL N'Y A PAS DE TEST POUR VERIFIER SI LES CELLULES SONT DEJA OCCUPEES, VERIFIEZ QUE DE LA PLACE EST DISPONIBLE EN BAS ET A DROITE.
A valider via CTRL+MAJ+ENTREE
Public Function FILTREVBA(arr As Range, filter As Variant) As Variant
On Error GoTo quitFunc
Dim inputDim(0 To 1) As Long
inputDim(0) = arr.Rows.Count
inputDim(1) = arr.Columns.Count
Dim dimensions(0 To 1) As Long, vertical As Boolean
Select Case UBound(filter) - LBound(filter) + 1
Case inputDim(0)
vertical = True
filter = Application.Transpose(filter)
dimensions(0) = arr.Rows.Count
dimensions(1) = arr.Columns.Count
Case inputDim(1)
vertical = False
dimensions(0) = arr.Columns.Count
dimensions(1) = arr.Rows.Count
Case Else
FILTREVBA = "Entrées invalides"
Exit Function
End Select
Dim filteredValues As Object
Set filteredValues = CreateObject("System.Collections.ArrayList")
Dim evaluation As Variant, i As Long
For i = 1 To dimensions(0)
If filter(i) Then
If vertical Then
filteredValues.Add arr.Rows(i)
Else
filteredValues.Add Application.Transpose(arr.Columns(i))
End If
End If
Next i
If Not vertical And dimensions(1) > 1 Then
FILTREVBA = Application.Transpose(filteredValues.toArray)
Else
FILTREVBA = filteredValues.toArray
End If
Dim outputDim(0 To 1) As Long
outputDim(0) = 1: outputDim(1) = 1
On Error Resume Next
outputDim(0) = UBound(FILTREVBA, 1): outputDim(1) = IIf(dimensions(1) > 1, UBound(FILTREVBA, 2), 1)
On Error GoTo 0
'Application.EnableEvents = False
ActiveCell.Resize(outputDim(0), outputDim(1)).FormulaArray = ActiveCell.Formula
Application.EnableEvents = True
quitFunc:
End Function