Lire et traiter un array d'un classeur fermé

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

J'ai un classeur avec un userform me permettant de rechercher un mot clé et afficher toutes les lignes d'une base de donnée contenant ce mot clé dans mon userform.

Pour l'instant la table se trouve dans le même classeur que le userform.

Est-il possible de faire la même chose, mais lorsque la base de donnée se trouve dans un autre classeur et sans ouvrir et le fermer pour traiter la requete et sans copier la table dans le classeur contenant le userform (perte de temps) au moyen d'une procédure ADO par exemple ?

Je ne maitrise pas totalement cette technique donc votre aide me serait la bienvenue. Je vous remercie d'avance grandement pour votre aide.

Voici le code
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 58 59 Private Sub T1_Change() Dim i&, fin&, y&, a&, mem As Boolean Application.ScreenUpdating = 0 If mem1 Then Exit Sub If T1 = "" Then ListBox1.Clear: T2 = "": T3 = "": T4 = "": T5 = "": C3.Visible = 0: C4.Visible = 0: Exit Sub ListBox1.Clear ' ici référence à l'array se trouve dans la même feuille que le userform With Feuil1 y = 1 fin = .Range("A" & Rows.Count).End(xlUp).Row aa = .Range("A2:F" & fin) End With For i = 1 To UBound(aa) aa(i, 5) = i + 1 Next i For i = 1 To UBound(aa) For a = 1 To UBound(aa, 2) If aa(i, a) Like "*" & T1 & "*" Then aa(i, 6) = "oui": y = y + 1: Exit For Next a Next i If y = 1 Then Exit Sub If y = 2 Then ' de 1 à l'indice 8 For i = 1 To UBound(aa) If aa(i, 6) = "oui" Then ListBox1.AddItem aa(i, 1) ' de l 'indice 1 à l'indice 4 For a = 1 To UBound(aa, 2) - 2 ListBox1.List(ListBox1.ListCount - 1, a - 1) = aa(i, a) Controls("T" & a + 1) = aa(i, a) Next a mem = 1: Exit For End If Next i Else ReDim bb(y - 1, UBound(aa, 2) - 1) y = 1 For i = 1 To UBound(aa) If aa(i, 6) = "oui" Then For a = 1 To UBound(aa, 2) - 1 bb(y, a) = aa(i, a) Next a y = y + 1 End If Next i End If With ListBox1 .ColumnCount = 5 .ColumnWidths = "80;80;50;80;0" If mem Then Exit Sub .List = bb End With End Sub

Bonjour,

Une piste avec une partie d'un code posté il y a quelques jours ici !
Je n'ai pas ouvert ton classeur mais le code est facilement adaptable à tes besoins :

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
 
Sub RecupValeurs()
 
    Dim Classeur As String
    Dim TblValeurs() As Variant
 
    Classeur = "F:\Liste Clients.xls"
 
    'ici, les colonnes cibles sont de A à F, adapter...
    TblValeurs = ValeursClasseur(Classeur, "Clients", "A:F", "Nom", "Silve")
 
    'inscrit les valeurs à partir de A1 de la feuille active, à adpter...
    Range(Cells(1, 1), Cells(UBound(TblValeurs, 1), UBound(TblValeurs, 2))) = TblValeurs
 
 
End Sub
 
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Fichier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
 
    If Not IsMissing(Rs) Then
 
        Set Rs = CreateObject("ADODB.Recordset")
 
    End If
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Fichier & ";" & _
              "Extended Properties=""Excel 8.0;HDR=YES;IMEX=2;"""
 
End Sub
 
Function ValeursClasseur(Classeur As String, _
                         Feuille As String, _
                         Plage As String, _
                         NomChamp As String, _
                         Nom As String) As Variant()
 
    Dim ConnectCL As Object
    Dim Rs As Object
    Dim Champ As Object
    Dim TblValeurs() As Variant
    Dim I As Integer
    Dim J As Integer
 
    'ouvre la connexion
    ConnectCLasseur ConnectCL, Classeur, Rs
 
    'récup des valeurs
    With Rs
 
        On Error Resume Next
        .CursorType = 1
        .LockType = 3
        .Open "SELECT * FROM `" & Feuille & "$" & Plage & "` WHERE " & NomChamp & " LIKE '%" & Nom & "%'", ConnectCL
        .MoveFirst
 
        If Err.Number <> 0 Then
 
            ReDim TblValeurs(1 To 1, 1 To 1)
            TblValeurs(1, 1) = "Non trouvé !"
             ValeursClasseur = TblValeurs()
             Exit Function
 
        End If
 
        'stocke les valeurs dans un tableau
        ReDim TblValeurs(1 To .RecordCount, _
                         1 To .Fields.Count)
 
        Do While Not .EOF
 
            I = I + 1
 
            For Each Champ In .Fields
 
                J = J + 1
                TblValeurs(I, J) = Champ.Value
 
            Next
 
            J = 0
 
            .MoveNext
 
        Loop
 
    End With
 
    ValeursClasseur = TblValeurs()
 
    'ferme la connexion
    ConnectCL.Close
 
    Set Rs = Nothing
    Set ConnectCL = Nothing
 
End Function

Hervé.

Salut Hervé,

Merci pour ta réponse,

Finalement j'ai opté pour une solution plus simple:

copier l'intégralité de la DB fermé dans une feuille du classeur sur lequel je travaille et traiter le contenu à partir de ma macro existante.

A partir de l'userform dont je parlais, j'ai quelques macros permettant de modifier et supprimer les lignes sélectionnés par l'utilisateur.

Ca marche très bien :-) je suis presque aux bouts de mes peines.

Voici ma structures ADODB permettant de modifier une ligne d'un classeur fermé pour ceux que ca intéresse:

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
 
 
Private Sub C4_Click()
    Dim lig&, i&, memo$
    If ListBox1.ListIndex = -1 Then Exit Sub
    Dim fichierdocument As String
    Dim iddocument As Long
    Dim feuille As String
    Dim chemin As String
    Dim Cn As ADODB.Connection
    Dim Fichier As String
    Dim texte_SQL As String
 
    ' variables de controle
 
    Dim typedoc As String
    Dim numdoc As Long
    Dim datedoc As String
    Dim nomclient As String
    Dim numprojet As String
    Dim titreprojet As String
    Dim totprojet As Long
    Dim ac As Long
    Dim totfacture As Long
    typedoc = Controls("T2")
    numdoc = Controls("T3")
    datedoc = Controls("T4")
    nomclient = Controls("T5")
    numprojet = Controls("T6")
    titreprojet = Controls("T7")
    totprojet = Controls("T8")
    ac = Controls("T9")
    totfacture = Controls("T10")
 
    chemin = Worksheets("INPUT").Range("A19")
    fichierdocument = "db_document.xlsx"
    iddocument = Worksheets("Export").Cells(ListBox1.List(ListBox1.ListIndex, 9), 21).Value
    Fichier = chemin & fichierdocument
    feuille = "DOCUMENT"
 
 
    Set Cn = New ADODB.Connection
 
    '--- Connexion ---
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With
    '-----------------
 
    'Définit la requête.
    '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
    texte_SQL = "UPDATE [" & feuille & "$] SET NUM_DOCUMENT =  " & numdoc & ", " & _
    " TYPE_DOCUMENT =  '" & Replace(typedoc, "'", "''") & "', " & _
    " DATE_DOCUMENT = '" & Replace(datedoc, "'", "''") & "',  " & _
    " NOM_CLIENT = '" & Replace(nomclient, "'", "''") & "', " & _
    " NUM_PROJET = '" & Replace(numprojet, "'", "''") & "', " & _
    " TITRE_PROJET = '" & Replace(titreprojet, "'", "''") & "', " & _
    " TOTAL_PROJET = " & Replace(totprojet, "'", "''") & ", " & _
    " ACOMPTE = " & Replace(ac, "'", "''") & ", " & _
    " TOTAL_FACTURE = " & Replace(totfacture, "'", "''") & " WHERE ID = " & iddocument
 
    Cn.Execute texte_SQL
 
    'texte_SQL = "UPDATE [" & feuille & "$] SET TYPE_DOCUMENT =  '" & typedoc & "' WHERE ID = " & iddocument
 
    'Cn.Execute texte_SQL
 
    '--- Fermeture connexion ---
    Cn.Close
    Set Cn = Nothing
 
    memo = T1
    Unload Documentrechercheform
    Documentrechercheform.T1 = memo
    Documentrechercheform.Show