Je cherche à formater des numéros d'une certaine facon
genre 1,2,3,4,6,9,10,11 deviens 1:4,6,9:11
J'ai fait ca mais ca marche pas du tout...et je sais pas trop comment m'y
prendre. Les chiffres dans la collection cdata sont déjà en ordre numérique.
Public Function fromto(ByVal cdata As Collection) As String
Dim i As Integer
Dim tempstart As Double
Dim finalstring As String
Dim tempvaleur As Double
tempstart = cdata.Item(1)
tempvaleur = cdata.Item(1)
For i = 2 To cdata.Count
If tempvaleur + 1 <> cdata.Item(i) Then
finalstring = finalstring & ":" & tempvaleur & " , "
Else
finalstring = tempstart
End If
tempvaleur = cdata.Item(i)
Next i
finalstring = finalstring & ":" & cdata.Item(cdata.Count)
Debug.Print finalstring
End Function
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
jean-marc
>"John Smith" a écrit dans le message de
news:
Salut,
Je cherche à formater des numéros d'une certaine facon
genre 1,2,3,4,6,9,10,11 deviens 1:4,6,9:11
J'ai fait ca mais ca marche pas du tout...et je sais pas trop comment
m'y
prendre. Les chiffres dans la collection cdata sont déjà en ordre
numérique.
Hello,
un peu d'algorithmique pour un retour de vacances, sympa ça!
Voici la bête: ' '----------------------------------------------------------------------- ---------------- ' Procedure : fromto ' DateTime : 24/07/2006 20:29 ' Author : Jean-Marc ' Purpose : Compacte une "collection" de valeurs déja triées en ' ordre croissant. ' Exemple : 1,2,3,4,6,9,10,11 ==> 1:4,6,9:11 '----------------------------------------------------------------------- ---------------- ' Public Function fromto(ByVal cdata As Collection) As String Dim idx As Long Dim vidx As Double Dim vc As Double Dim vp As Double Dim tmpResult As String Dim suite As Boolean
If cdata.Count = 1 Then fromto = CStr(cdata.Item(1)) Exit Function Else vidx = cdata.Item(1) vp = vidx idx = 2 While idx <= cdata.Count vc = cdata.Item(idx) If (vp + 1) = vc Then suite = True vp = vc Else If suite Then tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp) Else tmpResult = tmpResult & "," & vp End If vidx = vc vp = vc suite = False End If idx = idx + 1 Wend If suite Then tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp) Else tmpResult = tmpResult & "," & vc End If End If fromto = Mid$(tmpResult, 2) End Function
Et voici de quoi tester: Private Sub Command1_Click() Dim cc As Collection Dim result As String
' remplit la collection : 1,2,3,4,6,9,10,11 Set cc = New Collection cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4): cc.Add (6): cc.Add (9): cc.Add (10): cc.Add (11) result = fromto(cc) Debug.Print result;: If result = "1:4,6,9:11" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (2) result = fromto(cc) Debug.Print result;: If result = "1:2" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4) result = fromto(cc) Debug.Print result;: If result = "1:4" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (3): cc.Add (4): cc.Add (5): cc.Add (7): cc.Add (9) result = fromto(cc) Debug.Print result;: If result = "1,3:5,7,9" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
End Sub
Mes tests unitaires sont ok.
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
>"John Smith" <spam@spam.com> a écrit dans le message de
news:etbS9x0rGHA.4272@TK2MSFTNGP03.phx.gbl...
Salut,
Je cherche à formater des numéros d'une certaine facon
genre 1,2,3,4,6,9,10,11 deviens 1:4,6,9:11
J'ai fait ca mais ca marche pas du tout...et je sais pas trop comment
m'y
prendre. Les chiffres dans la collection cdata sont déjà en ordre
numérique.
Hello,
un peu d'algorithmique pour un retour de vacances, sympa ça!
Voici la bête:
'
'-----------------------------------------------------------------------
----------------
' Procedure : fromto
' DateTime : 24/07/2006 20:29
' Author : Jean-Marc
' Purpose : Compacte une "collection" de valeurs déja triées en
' ordre croissant.
' Exemple : 1,2,3,4,6,9,10,11 ==> 1:4,6,9:11
'-----------------------------------------------------------------------
----------------
'
Public Function fromto(ByVal cdata As Collection) As String
Dim idx As Long
Dim vidx As Double
Dim vc As Double
Dim vp As Double
Dim tmpResult As String
Dim suite As Boolean
If cdata.Count = 1 Then
fromto = CStr(cdata.Item(1))
Exit Function
Else
vidx = cdata.Item(1)
vp = vidx
idx = 2
While idx <= cdata.Count
vc = cdata.Item(idx)
If (vp + 1) = vc Then
suite = True
vp = vc
Else
If suite Then
tmpResult = tmpResult & "," & CStr(vidx) & ":" &
CStr(vp)
Else
tmpResult = tmpResult & "," & vp
End If
vidx = vc
vp = vc
suite = False
End If
idx = idx + 1
Wend
If suite Then
tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp)
Else
tmpResult = tmpResult & "," & vc
End If
End If
fromto = Mid$(tmpResult, 2)
End Function
Et voici de quoi tester:
Private Sub Command1_Click()
Dim cc As Collection
Dim result As String
' remplit la collection : 1,2,3,4,6,9,10,11
Set cc = New Collection
cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4): cc.Add (6): cc.Add
(9): cc.Add (10): cc.Add (11)
result = fromto(cc)
Debug.Print result;: If result = "1:4,6,9:11" Then Debug.Print "
==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing
Set cc = New Collection
cc.Add (1): cc.Add (2)
result = fromto(cc)
Debug.Print result;: If result = "1:2" Then Debug.Print " ==> OK"
Else Debug.Print " ==> KO"
Set cc = Nothing
Set cc = New Collection
cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4)
result = fromto(cc)
Debug.Print result;: If result = "1:4" Then Debug.Print " ==> OK"
Else Debug.Print " ==> KO"
Set cc = Nothing
Set cc = New Collection
cc.Add (1): cc.Add (3): cc.Add (4): cc.Add (5): cc.Add (7): cc.Add
(9)
result = fromto(cc)
Debug.Print result;: If result = "1,3:5,7,9" Then Debug.Print "
==> OK" Else Debug.Print " ==> KO"
End Sub
Mes tests unitaires sont ok.
--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
Je cherche à formater des numéros d'une certaine facon
genre 1,2,3,4,6,9,10,11 deviens 1:4,6,9:11
J'ai fait ca mais ca marche pas du tout...et je sais pas trop comment
m'y
prendre. Les chiffres dans la collection cdata sont déjà en ordre
numérique.
Hello,
un peu d'algorithmique pour un retour de vacances, sympa ça!
Voici la bête: ' '----------------------------------------------------------------------- ---------------- ' Procedure : fromto ' DateTime : 24/07/2006 20:29 ' Author : Jean-Marc ' Purpose : Compacte une "collection" de valeurs déja triées en ' ordre croissant. ' Exemple : 1,2,3,4,6,9,10,11 ==> 1:4,6,9:11 '----------------------------------------------------------------------- ---------------- ' Public Function fromto(ByVal cdata As Collection) As String Dim idx As Long Dim vidx As Double Dim vc As Double Dim vp As Double Dim tmpResult As String Dim suite As Boolean
If cdata.Count = 1 Then fromto = CStr(cdata.Item(1)) Exit Function Else vidx = cdata.Item(1) vp = vidx idx = 2 While idx <= cdata.Count vc = cdata.Item(idx) If (vp + 1) = vc Then suite = True vp = vc Else If suite Then tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp) Else tmpResult = tmpResult & "," & vp End If vidx = vc vp = vc suite = False End If idx = idx + 1 Wend If suite Then tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp) Else tmpResult = tmpResult & "," & vc End If End If fromto = Mid$(tmpResult, 2) End Function
Et voici de quoi tester: Private Sub Command1_Click() Dim cc As Collection Dim result As String
' remplit la collection : 1,2,3,4,6,9,10,11 Set cc = New Collection cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4): cc.Add (6): cc.Add (9): cc.Add (10): cc.Add (11) result = fromto(cc) Debug.Print result;: If result = "1:4,6,9:11" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (2) result = fromto(cc) Debug.Print result;: If result = "1:2" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4) result = fromto(cc) Debug.Print result;: If result = "1:4" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
Set cc = Nothing Set cc = New Collection cc.Add (1): cc.Add (3): cc.Add (4): cc.Add (5): cc.Add (7): cc.Add (9) result = fromto(cc) Debug.Print result;: If result = "1,3:5,7,9" Then Debug.Print " ==> OK" Else Debug.Print " ==> KO"
End Sub
Mes tests unitaires sont ok.
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
jean-marc
J'ai oublié 2 Cstr() dans les else ...
C'est un algo amusant à donner en test pour un entretien d'embauche :-)
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
J'ai oublié 2 Cstr() dans les else ...
C'est un algo amusant à donner en test pour un
entretien d'embauche :-)
--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
C'est un algo amusant à donner en test pour un entretien d'embauche :-)
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
John Smith
Merci
Ca marche numéro 1!!!
"jean-marc" wrote in message news:44c51c18$0$32435$
J'ai oublié 2 Cstr() dans les else ...
C'est un algo amusant à donner en test pour un entretien d'embauche :-)
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
Merci
Ca marche numéro 1!!!
"jean-marc" <NOSPAM_jean_marc_n2@yahoo.fr> wrote in message
news:44c51c18$0$32435$ba620e4c@news.skynet.be...
J'ai oublié 2 Cstr() dans les else ...
C'est un algo amusant à donner en test pour un
entretien d'embauche :-)
--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
"jean-marc" wrote in message news:44c51c18$0$32435$
J'ai oublié 2 Cstr() dans les else ...
C'est un algo amusant à donner en test pour un entretien d'embauche :-)
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
jean-marc
"John Smith" a écrit dans le message de news:
Merci
Ca marche numéro 1!!!
Merci du retour! Content d' avoir pu t'aider :-)
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
"John Smith" <spam@spam.com> a écrit dans le message de
news:Ok9Jni1rGHA.4676@TK2MSFTNGP05.phx.gbl...
Merci
Ca marche numéro 1!!!
Merci du retour! Content d' avoir pu t'aider :-)
--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
-- Jean-marc Tester mon serveur (VB6) => http://myjmnhome.dyndns.org "There are only 10 kind of people those who understand binary and those who don't." mailto: remove '_no_spam_' ;
