Bug avec ma fonction VBA

Version imprimable

Bonsoir tout le monde, voila j'ai une fonction VBA qui est supposee recuperer les installations correspondants a un nom d'etablissement qui a ete saisie dans la cellule passee en parametre a la fonction. Au niveau modelisation, un etablissement est donc compose de plusieurs installations. Puis je veux mettre ces installations recuperees dans une liste pour validation de donnee (un menu deroulant).
Or j'obtiens un bug quqnd j'essaie de lancer ma fonction, j'ai une fenetre avec seulement une croix rouge qui s'affiche, et avec rien de marque a l'interieur.
Voici le code de ma fonction :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Public Function getInstallationsFromEtab(cellEtab As Range)
 
On Error GoTo Err
 
Dim etab As String
etab = cellEtab.Value
 
 
Dim oWks As DAO.WorkSpace
Dim oDB As DAO.Database
 
Set oWks = DbEngine.CreateWorkSpace("monWorkspace", "admin", "", dbUseJet)
Set oDB = oWks.OpenDatabase("CheminDeMaBase")
LSQL = "SELECT Installations.nom FROM Etablissements, Installations WHERE Installations.etablissementId = Etablissements.etablissementId AND ((Etablissements.nomEtablissement = '" & etab & " ')); "
 
Set lrs = oDB.OpenRecordset(LSQL)
Dim listInstall As String
 
 
If Not IsEmpty(lrs) Then
 
    listInstall = lrs("nom")
    lrs.moveNext
 
    Do While lrs.EOF = False
        listInstall = listInstall & ", " & lrs("nom")
        lrs.moveNext
    Loop
 
Else
    listInstall = ""
End If
MsgBox "6"
    ActiveCell.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, _
        AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=listInstall
        .IgnoreBlank = True9
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
 
ExitFunction:
    Exit Function
 
Err:
    MsgBox "erreur : " & Err.Description
    Resume ExitFunction
 
End Function

Si vous avez des solutions, je suis preneur !!
Merci d'avance :)

Bonsoir
Une fonction ne peut pas créer une liste de validation dans la cellule d'où elle a été appelée.

Edit: Tu peux utiliser une sub telle que:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
'Activer la référence Microsoft DAO xx.x
Sub getInstallationsFromEtab()
Dim oWks As DAO.Workspace
Dim oDB As DAO.Database
Dim Lrs As DAO.Recordset
Dim ListInstall As String, Etab As String, Lsql As String
 
With Sheets("Feuil3")
    Etab = .Range("A1").Value
    .Range("B1").Validation.Delete
    Set oWks = DbEngine.CreateWorkSpace("monWorkspace", "admin", "", dbUseJet)
    Set oDB = oWks.OpenDatabase("CheminDeTaBase")
    Lsql = "SELECT ...." & Etab & "; "
    Set Lrs = oDB.OpenRecordset(Lsql)
    If Not IsEmpty(Lrs) Then
        Do While Not Lrs.EOF
            ListInstall = ListInstall & ", " & Lrs("nom")
            Lrs.moveNext
        Loop
        .Range("B1").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                                    Operator:=xlBetween, Formula1:=Mid(ListInstall, 2)
    End If
End With
Set oWks = Nothing
Set oDB = Nothing
Set Lrs = Nothing
End Sub

11/05/2011, 16h02
robx2309

Merci pour la réponse, et donc si j'ai bien comprit il n'y a pas moyen d'appeler une sub a partir d'une cellule ? Parce que moi ce que je voudrais faire c'est pouvoir utiliser cette sub dans toute une colonne, t'aurais une idée de comment je pourrais faire ?
Ce qui me conviendrait le mieux ca serait que je puisse appeler ma sub d'une cellule, et lui passer en parametre le range d'une cellule (celle qui contient le nom de l'etablissement)