Sub tata()
Dim i&, j&, n&, d$, f$, p$, s$(), x()
d = [A3].Value 'borne inférieure.
f = [C3].Value 'borne supérieure.
With [G3] 'première cellule de résultat.
.Resize(2, 1).Value = 1
Range(.Cells, Cells(Rows.Count, .Column).End(xlUp)).ClearContents
j = CLng(d)
n = CLng(f) - j
ReDim s(0 To n, 1 To 1)
p = Left$(String(15, "0"), Len(d))
For i = 0 To n: s(i, 1) = Format(j + i, p): Next
x = tutu(s)
Do
n = x(1)
ReDim s(0 To n, 1 To 1)
For i = 0 To n: s(i, 1) = x(0)(i, 1): Next
x = tutu(s)
Loop Until x(1) = n
.Resize(x(1) + 1, 1).Value = x(0)
End With
End Sub
Private Function tutu(s)
Dim i&, j&, k&, l&, n&, p$, t$()
n = UBound(s)
ReDim t(0 To n, 1 To 1)
p = Left$(s(0, 1), s(0, 1) - 1)
l = -1
For i = 0 To n
If s(i, 1) Like p & "?" Then
k = k + 1
Else
If k = 10 Then
l = l + 1
t(l, 1) = p
Else
For j = 1 To k: t(l + j, 1) = s(i + j - k - 1, 1): Next
l = l + k
End If
k = 1
p = Left$(s(i, 1), Len(s(i, 1)) - 1)
End If
Next
If k = 10 Then
l = l + 1
t(l, 1) = p
Else
For j = 1 To k: t(l + j, 1) = s(n + j - k, 1): Next
l = l + k
End If
tutu = Array(t, l)
End Function