Bonjour,
Sub tata()
Dim i&, j&, k&, l&, n&, d$, f$, p$, s$(), t$()
d = [A3].Value 'borne inférieure
f = [C3].Value 'borne supérieure
n = CLng(f) - CLng(d)
ReDim s(0 To n, 1 To 1)
ReDim t(0 To n, 1 To 1)
p = Left$(String(15, "0"), Len(d))
j = CLng(d)
For i = 0 To n
s(i, 1) = Format(j + i, p)
Next
p = Left$(s(0, 1), Len(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(i + j - k - 1, 1): Next
l = l + k
End If
With [G3] 'première cellule de résultat
.Resize(2, 1).Value = t
Range(.Cells, Cells(Rows.Count, .Column).End(xlUp)).ClearContents
.Resize(l + 1, 1).Value = t
End With
End SubJe me doutais bien qu'on n'en resterait pas là... (Une question peut en cacher une autre.)
Merci infiniment car c'est exactement la macro que je voulais.
Une dernière petite question pour allée encore plus loin c'est de rajout a la macro un regroupement une tranche de centaine exemple :0235066100-0235066199 > resultat 02350661
Merci encore pour votre aide.
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 FunctionTout est possible, excepté ce qui ne l'est pas.
Sub tata()
Dim i&, j&, n&, d$, f$, g$, p$, s$(), x(), cl As Sort
d = [A3].Value 'borne inférieure.
f = [C3].Value 'borne supérieure.
g = [A6].Value 'valeur insérée.
With [G3] 'première cellule de résultat.
.Resize(2, 1).Value = 1
With Range(.Cells, Cells(Rows.Count, .Column).End(xlUp)): .ClearContents: .Font.ColorIndex = xlAutomatic: End With
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
.Value = "'" & g
.Font.Color = -16776961
.Resize(x(1) + 1, 1).Offset(1).Value = x(0)
Set cl = Me.Sort
cl.SortFields.Clear
cl.SortFields.Add Key:=.Resize(x(1) + 2, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
cl.SetRange .Resize(x(1) + 2, 1)
cl.Header = xlNo
cl.MatchCase = False
cl.Orientation = xlTopToBottom
cl.Apply
.Resize(x(1) + 2, 1).RemoveDuplicates Columns:=1, Header:=xlNo
End With
End Sub Set cl = Me.Sort
cl.SortFields.Clear
cl.SortFields.Add Key:=.Resize(x(1) + 2, 1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
cl.SetRange .Resize(x(1) + 2, 1)
cl.Header = xlNo
cl.MatchCase = False
cl.Orientation = xlTopToBottom
cl.Apply
.Resize(x(1) + 2, 1).RemoveDuplicates Columns:=1, Header:=xlNoComme prévu, hélas...
Sub tata()
Dim i&, j&, n&, d$, f$, g$, p$, s$(), x(), cl As Sort
d = [A3].Value 'borne inférieure.
f = [C3].Value 'borne supérieure.
g = [A6].Value 'valeur insérée.
With [G3] 'première cellule de résultat.
.Resize(2, 1).Value = 1
With Range(.Cells, Cells(Rows.Count, .Column).End(xlUp)): .ClearContents: .Font.ColorIndex = xlAutomatic: End With
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
For i = 0 To n
If g = x(0)(i, 1) Then
j = -1: Exit For
ElseIf g < x(0)(i, 1) Then
j = -2: Exit For
End If
Next
.Resize(x(1) + 1, 1).Value = x(0)
Select Case j
Case -1
.Offset(i).Font.Color = -16776961
Case -2
.Offset(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
.Offset(i + (i = 0)).Value = "'" & g
.Offset(i + (i = 0)).Font.Color = -16776961
Case Else
.Offset(i).NumberFormat = "General"
.Offset(i).Value = "'" & g
.Offset(i).Font.Color = -16776961
End Select
End With
End Sub
mais un petit souci sur le fonctionnement suite a ma dernière demande "l'ajout du numéro à isoler" le principe c'est quand le numéro ce trouve dans la tranche il s'affiche en rouge pas problème mais dans le cas le numéro se situe dans la tranche. exemple : la tranche (0477808000-0477808199) et numéro à isoler 0477808080 logiquement le résultat finale=
Je comprends qu'il faut adjoindre une valeur isolée supplémentaire à la liste, et l'écrire en rouge. J'ai beau le relire attentivement, je ne comprends pas comment ce texte peut signifier qu'il faut supprimer un des éléments obtenus à l'étape 2 (04778080), ajouter 9 éléments qui avaient disparus dès l'étape 1, et 8 autres extraits de la liste de l'étape 1...
