Of course you could skip Preserve and Transpose.
[VBA]Sub DoesWork2()
Dim x() As Variant
Dim i As Long
Dim j As Long
Dim r As Range
Dim c As Range

Set r = Range("A1:A10")
'j = [SUMPRODUCT((MOD(A1:A10,2)=0)+0)]
j = Evaluate("SUMPRODUCT((MOD(" & r.Address & ",2)=0)+0)")
ReDim x(1 To j, 1 To 1)
If j = 0 Then Exit Sub
j = 0
'For i = 1 To 10
For Each c In r
If c Mod 2 = 0 Then
j = j + 1
x(j, 1) = c.Value
End If
Next c

Range("B1").Resize(UBound(x)) = x
End Sub[/VBA]