problème primaire de tableaux

Question

Admettons un tableau as string, mettons
dim Noms(120), rempli de chaines de caractères parfois identiques.
admettons un autre tableau, vide, NomUnique(x) as string.
Bon. Je voudrais mettre dans le tableau NomUnique( ) les chaines de
caractère du tableau Noms(120), mais attention : sans redondance, sans
doublon, c'est à dire que dans NomUnique( ) il n'y aura pas deux fois la
même chaine de caractères.

Quelqu'un peut-il me faire le code, je bloque, je m'embrouille dans les for
next.....

Merci !!

Nico · Answer

' Pour voir les resultats obtenu creer 2 listbox list1 et list2
' il y a 2 methode selon si ton tableau initial est trier ou non

Const nbelement As Integer = 5

Private Sub tableau_non_trier()

' Voici une 1ere methode pour ton probleme
' Cas ou ton tableau de départ n'est pas trier
' Tu cree ton tableau initiale de type structure
' dans un module tu mets :
Type struct
str1 As String
int1 As Integer
End Type

' puis ou tu veux dans ta form
' tu déclare ton tableau de type struct(par ex)

Dim tab1(1 To nbelement) As struct
Dim tab2(1 To nbelement) As String

' initialise tab1.int1 a 0, il prend -1 si il y a occurence
For i = 1 To nbelement
tab1(i).int1 = 0
Next i

tab1(1).str1 = " abc"
tab1(2).str1 = "abcd"
tab1(3).str1 = " abc "
tab1(4).str1 = " abcd"
tab1(5).str1 = "abc"

For i = 1 To 5
List1.AddItem tab1(i).str1
Next i

' Analyse les occurences
For i = 1 To nbelement
For j = i + 1 To nbelement
If (Trim(tab1(i).str1) = Trim(tab1(j).str1)) And tab1 (i).int1 >= 0 Then
tab1(i).int1 = -1
End If
Next j
Next i

' Affichage dans la liste du résultat
For i = 1 To nbelement
If tab1(i).int1 <> -1 Then
List2.AddItem Trim(tab1(i).str1)
End If
Next i

End Sub

Private Sub tableau_trier()
' 2e cas, ton tableau de depart est trier
Dim tab1(1 To nbelement) As String
Dim tab2(1 To nbelement) As String

Dim i As Integer
Dim j As Integer
Dim temp As String

' Classe le tableau
tab1(1) = " abc"
tab1(2) = "abcd"
tab1(3) = " abc "
tab1(4) = " abcd"
tab1(5) = "abc"

For i = 1 To 5
List1.AddItem tab1(i)
Next i

' Classer par ordre alphabétique du tab1
For i = 1 To nbelement
For j = i + 1 To nbelement
If Trim(tab1(i)) > Trim(tab1(j)) Then
temp = tab1(j)
tab1(j) = tab1(i)
tab1(i) = temp
End If
Next j
Next i

' cherche les occurences si non met dans ton 2e tableau
i = 1
j = 1

While i < nbelement
If Trim(tab1(i)) = Trim(tab1(i + 1)) Then
tab2(j) = tab1(i)
j = j + 1
i = i + 1
If i < nbelement Then
While Trim(tab1(i)) = Trim(tab1(i + 1))
i = i + 1
Wend
i = i + 1
End If
End If
Wend

For i = 1 To j
List2.AddItem Trim(tab2(i))
Next i

' A noter que trim efface les espaces sur les cotés

Mariner · Answer

Voici deux des mes vieilles fonctions:

Public Function EliminerDoublons(ByRef Tableau1() As String) As Long
 '
 ' Prend un tableau de chaines et détruit les doublons
 '
 ' Retourne le nombre de doublons éliminés
 '
 Dim Cmpt1 As Long           ' Boucle
 Dim Cmpt2 As Long           ' Boucle 2
 Dim strItem As String       ' L'item
 
 EliminerDoublons = UBound(Tableau1)

 'On additionne pour chaque item distinct et recopie dans le même tableau à l'indice Cmpt2
 For Cmpt2 = 0 To (EliminerDoublons - 1)
   strItem = Tableau1(Cmpt2)
   If (strItem <> vbNullString) Then  'Si cet item n'as pas déjà été compilé...
     ' On compare l'item tableau1(Cmpt2) au reste de la liste.
     For Cmpt1 = (Cmpt2 + 1) To EliminerDoublons
      If (StrComp(Tableau1(Cmpt1), strItem, vbTextCompare) = 0) Then
         Tableau1(Cmpt1) = vbNullString
       'Else
      End If
     Next Cmpt1
   End If
 Next Cmpt2
 
 'On enlève les éléments vides...
 Call CompresserListeStr(Tableau1)
 EliminerDoublons = EliminerDoublons - UBound(Tableau1)

End Function

Public Sub CompresserListeStr(ByRef InListe() As String)
 '
 ' InListe contient un tableau d'items dont certains
 ' peuvent être Null. Cette fonction recopie les items de
 ' façon à placer toutes les chaines vide à la fin et
 ' réduire la taille du tableau.
 '
 Dim Nombre As Long
 Dim Cmpt As Long
 Dim Cmpt2 As Long
 
 
 Nombre = UBound(InListe)
 'Compresser la liste en déplacant les items vers le haut...
 Do While (Cmpt < Nombre)
   If (InListe(Cmpt) <> vbNullString) Then
       Cmpt = Cmpt + 1
     Else
       Cmpt2 = Cmpt
       Do While ((InListe(Cmpt) = vbNullString) And (Cmpt < Nombre))
         Cmpt = Cmpt + 1
       Loop
       
       InListe(Cmpt2) = InListe(Cmpt)
       InListe(Cmpt) = vbNullString
       
       If (Cmpt <> Nombre) Then Cmpt = Cmpt2 + 1
   End If
 Loop
 
 'Trouver la première ligne blanche et couper.
 Cmpt = -1
 Cmpt2 = -1
 Do While ((Cmpt < Nombre) And (Cmpt2 = -1))
   Cmpt = Cmpt + 1
      If InListe(Cmpt) vbNullString Then Cmpt2 Cmpt
 Loop
 
 If (Cmpt2 = -1) Then
     'Cas "Aucun blanc"
     Cmpt2 = Nombre
   Else
     'Cas au moins un blanc
     Cmpt2 = Cmpt2 - 1
     'Mais si rien dans liste, en principe impossible, forcer 0 pour éviter de planter
     If (Cmpt2 < 0) Then Cmpt2 = 0
 End If
 
 ReDim Preserve InListe(Cmpt2)
 
End Sub

Pour les utiliser, il te suffira de recopier tout les éléments d'un tableau vers l'autre puis d'appeller EliminerDoublons, tel que:

Call DoubleAuSimple(Noms, NomUnique)

Public Sub DoubleAuSimple(ByRef InTbl() As String, ByRef OutTbl() as String)
  Dim iCmpt as Integer
  Dim iNbr as Integer

  iNbr = UBound(InTbl)
  Redim OutTbl(iNbr)
  For iCmpt = 0 to iNbr
    OutTbl(iCmpt) = InTbl(iCmpt)
  Next iCmpt

  Call EliminerDoublons(OutTbl)
End Sub

Problème primaire de tableaux

2 réponses

Discussions similaires