VBA - suppression occurrence vide dans Array

Bonsoir,

Je travaille actuellement sur l'import d'une liste de villes dans un fichier depuis un autre. J'ai procédé à un tri via une procédure indiqué sur excelPratique.

La fonction de tri par ordre alphabétique renvoie un Array dont la première occurrence est vide. J'ai beau utiliser un Redim Preserve, je ne parviens pas à supprimer cet indice de l'array comportant un "vide".

J'ai joint le fichier ainsi qu'une capture d'écran

Merci de votre aide :)

Voici le code :

Sub villesReg_imp()
Dim bcExtr$, texte_sql$
Dim connexion As Object
Dim requete As Variant, reponse As Variant
Dim doublonsList$, villesUniques$
Dim villeTab As Variant, i As Integer, j As Integer
Dim plage_list As Range
Dim villeTab_transpose As Variant

If InStr(1, ThisWorkbook.Worksheets("ndfTrackin_gen").Range("E6").Value, "xlsx", 1) = 0 Then
MsgBox "Sélectionner un fichier BC_extract valide"
Exit Sub
End If

bcExtr = ThisWorkbook.Worksheets("ndfTrackin_gen").Range("E6").Value

Set connexion = CreateObject("ADODB.Connection")

With connexion
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & bcExtr & "; Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With

texte_sql = "SELECT [VILLE] FROM [MASTER DATA TODAY$] WHERE [MSKT]= 'Sebastien Haugmard';"
Set requete = connexion.Execute(texte_sql)

If Not requete.EOF Then
reponse = requete.GetRows
End If

Set plage_list = ThisWorkbook.Worksheets("ndfTrackin_gen").Range("P12")

i = 1
j = 0
ReDim villeTab(0 To j)
For i = LBound(reponse, 2) To UBound(reponse, 2)
If InStr(1, doublonsList, reponse(0, i), 1) = 0 And Len(reponse(0, i)) > 3 Then
villeTab(j) = UCase(reponse(0, i))
doublonsList = doublonsList & villeTab(j) & ", "
j = j + 1
ReDim Preserve villeTab(LBound(villeTab) To UBound(villeTab) + 1)
End If

Next i
'ReDim Preserve villeTab(LBound(villeTab) To UBound(villeTab) - 1)

Call triCroissant(villeTab, j)

'Erase villeTab(0)
'

With plage_list.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(villeTab, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Error"
.InputMessage = ""
.ErrorMessage = "Please Provide a Valid Input"
.ShowInput = True
.ShowError = True
End With

Set plage_list = ThisWorkbook.Worksheets("ndfTrackin_gen").Range("Q12")
villeTab_transpose = WorksheetFunction.Transpose(villeTab)
ReDim Preserve villeTab_transpose(LBound(villeTab_transpose) To UBound(villeTab_transpose) - 1)
plage_list.Resize(UBound(villeTab_transpose), 1).Value = villeTab_transpose
End Sub

Sub triCroissant(tableau, ByVal j As Integer)
    Dim nb As Integer, tabTemp As Variant, i As Integer, pos As Integer, L As Integer, ii As Integer
    nb = UBound(tableau)
    tabTemp = tableau
    'Erase tableau
    ReDim tableau(0 To j)
    For i = 0 To nb
        pos = 0
        For L = 0 To nb
            If LCase(tabTemp(i)) > LCase(tabTemp(L)) And i <> L Then
                pos = pos + 1
            End If
        Next
        For ii = 1 To 1
            If tableau(pos) = "" Then
                tableau(pos) = tabTemp(i)
            Else
                pos = pos + 1
                ii = ii - 1
            End If
        Next
    Next
End Sub

Bonjour SHTOURS,

Attention avec ce fichier, il semble être détérioré

A+

bonjour brunoM45, shtours, le fil,

je n'ai pas les données de "reponse" alors je vous montre un exemple avec un array comme source. On ajoute les données comme "key" à un dictionaire, donc le resultat sera les entrées uniques ! Puis, si on transpose l'array des "keys" de ce dictionaire, le tri et le transpose de nouveau, vous obtenez le résultat voulu.

Sub teste()
     Dim x, Dict, i, arr1, arr2
     x = Array("b", "d", "z", "v", "a", "e", "b", "d", "z", "v", "a", "e", "b", "d", "z", "v", "a", "e")   'vos données
     Set Dict = CreateObject("scripting.dictionary")     'utilisez un dictionaire
     Dict.comparemode = vbTextCompare     'majuscules=minuscules
     For i = 0 To UBound(x)     'boucle vos données
          If Len(x(i)) >= 1 Then Dict(x(i)) = vbEmpty     'ajouter les données uniques
     Next i
     arr1 = Application.Transpose(Application.Sort(Application.Transpose(Dict.keys)))     '---> application.sort depuis excel 2021-365

     MsgBox Join(arr1, vbLf), vbInformation, "Résultat"

End Sub

Bonjour BrunoM, BsAllv,

Merci pour vos réponse.

L'erreur s'affichait car la validation des données obtenue par macro faisait appel à une source externe. Je viens de la supprimer

@BsAlv : Merci pour ta méthode ! Ca ne répond pas directement à ma question pôur la suppression de l'occurrence vide de l'array, mais ça me donne un cas à étudier pour faire les tri. J'ai déjà entendu parler de cette méthode avec dictionnaire

@BsAlv *Ca ne répond pas à ma question de suppression d'occurrence vide mais ça répond très bien à mon besoin initiale. C'est super

Merci beaucoup :)