Remplissage du tableau initial

**gilbapg** · 29/07/2013, 14h28

Bonjour,
J'ai écrit le script de ma macro
Qui prendra les valeur d'une base donné et va les mattre dans un tableau pour que je puisse chercher et filtrer
Mais ça ne marche pas
Mon tableau ne reste pas remplis quand je demande au "initialize" et je ne trouve pas le problème, ça vient de la fonction "populalistbox" parce que la "populacidades" marche trop bien

Le nom du tableau qu'il faut être remplis est listtotal et le nom du le tableau "orderby" aussi ne reste pas remplis, ce que devait être simple.

Est ce que quelqu'un peut m'aider et voir où c'est le problème? J'ai cassé ma tête toute la semaine derniere et le weekend

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
Private Sub UserForm_Initialize()
    orderby2.Clear
    orderby2.AddItem "Upward"
    orderby2.AddItem "Downward"
    orderby2.ListIndex = 0
 
    Call PopulaCidades
    Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)End Sub
 
Private Sub PopulaCidades()    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sql As String
 
    Set conn = New ADODB.Connection
    With conn
        .Provider = "Microsoft.JET.OLEDB.4.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
        .Open
    End With
 
    sql = "SELECT DISTINCT CountryLocation FROM [database$]"
 
    Set rst = New ADODB.Recordset
    With rst
        .ActiveConnection = conn
        .Open sql, conn, adOpenDynamic, _
              adLockBatchOptimistic
    End With
 
    Do While Not rst.EOF
        If Not IsNull(rst(0).Value) Then
            listcountry.AddItem rst(0).Value
        End If
        rst.MoveNext
    Loop
 
    Set rst = Nothing
    conn.Close
 
End Sub
 
Private Sub PopulaListBox(ByVal countryoffice As String, _
                          ByVal projectlocation As String, _
                          ByVal fieldlocation As String, _
                          ByVal sicompany As String, _
                          ByVal srdcompany As String, _
                          ByVal prediction As String)
 
    On Error GoTo TrataErro
 
    Dim rst As ADODB.Recordset
    Dim campo As Field
    Dim myArray() As Variant
    Dim i As Integer
 
    Set rst = PreecheRecordSet(countryoffice, projectlocation, fieldlocation, sicompany, srdcompany, predictionmethod)
 
    'prends le numero des choses enregistrés pour attribuer au listbox      
    listtotal.ColumnCount = rst.Fields.Count
 
    'remplis le combobox avec les noms du champs
    'reste le même indice
    Dim indiceTemp As Long
    indiceTemp = orderby.ListIndex
    orderby.Clear
    For Each campo In rst.Fields
        orderby.AddItem campo.Name
    Next
    'recupere l'indice selectioné
    orderby.ListIndex = indiceTemp
 
    'mets les lignes du recordset dans un array si il y a lignes dans celui là
    If Not rst.EOF And Not rst.BOF Then
        myArray = rst.GetRows
        'change linge par collune au away
        myArray = Array2DTranspose(myArray)
        'mets l'aways au listbox
        listtotal.list = myArray
        'ajoute la ligne de la colonne
        listtotal.AddItem , 0
        'remplis
        For i = 0 To rst.Fields.Count - 1
            listtotal.list(0, i) = rst.Fields(i).Name
        Next i
        'selectione le premier
        listtotal.ListIndex = 0
    Else
        listtotal.Clear
    End If
 
    'mets a jour le label
    If listtotal.ListCount <= 0 Then
        lblMensagens.Caption = listtotal.ListCount & " Records found"
    Else
        lblMensagens.Caption = listtotal.ListCount - 1 & " Records found"
    End If
 
    ' Fecha o conjunto de registros.
    Set rst = Nothing
    ' Fecha a conexão.
    'conn.Close
 
TrataSaida:
    Exit Sub
TrataErro:
    Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
    Resume TrataSaida
End Sub
 
Private Function PreecheRecordSet(ByVal countryoffice1 As String, _
                                  ByVal projectlocation1 As String, _
                                  ByVal fieldlocation1 As String, _
                                  ByVal sicompany1 As String, _
                                  ByVal srdcompany1 As String, _
                                  ByVal prediction1 As String) As Recordset
 
    On Error GoTo TrataErro
 
    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sql As String
    Dim sqlWhere As String
    Dim sqlOrderBy As String
    Dim i As Integer
    Dim campo As Field
    Dim myArray() As Variant
 
    Set conn = New ADODB.Connection
    With conn
        .Provider = "Microsoft.JET.OLEDB.4.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
        .Open
    End With
 
    sql = "SELECT * FROM [database$]"
 
    'creer WHERE
    'countryoffice
    Call MontaClausulaWhere(countryoffice.Name, "CountryOffice", sqlWhere)
 
    'ProjectLocation
    Call MontaClausulaWhere(projectlocation.Name, "ProjectLocation", sqlWhere)
 
    'FieldLocation
    Call MontaClausulaWhere(fieldlocation.Name, "FieldLocation", sqlWhere)
 
    'CountryLocation
    For i = 1 To listcountry.ListCount
        'verifica se o item está selecionado
        If listcountry.Selected(i - 1) Then
            'Monta a cláusula WHERE com OR
            Debug.Print listcountry.list(i - 1) & " selected"
            If sqlWhere <> vbNullString Then
                sqlWhere = sqlWhere & " OR"
            End If
            sqlWhere = sqlWhere & " UCASE(CountryLocation) LIKE UCASE('%" & Trim(listcountry.list(i - 1)) & "%')"
        End If
    Next
 
    'SICompany
    Call MontaClausulaWhere(sicompany.Name, "SICompany", sqlWhere)
 
    'SRDCompany
    Call MontaClausulaWhere(srdcompany.Name, "SRDCompany", sqlWhere)
 
    'PredictionMethod
    Call MontaClausulaWhere(predictionmethod.Name, "PredictionMethod", sqlWhere)
 
    'mescle string SQL avec WHERE
    If sqlWhere <> vbNullString Then
        sql = sql & " WHERE " & sqlWhere
    End If
 
    'mescle SQL avec ORDER BY
    If orderby.ListIndex <> -1 Then
        sqlOrderBy = " ORDER BY " & orderby.list(orderby.ListIndex, 0)
        'direction
        Select Case orderby2.ListIndex
        Case Upward
            sqlOrderBy = sqlOrderBy & " UP"
        Case Downward
            sqlOrderBy = sqlOrderBy & " DOWN"
        End Select
                sql = sql & sqlOrderBy
    End If
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseClient
    With rst
        .ActiveConnection = conn
        .Open sql, conn, adOpenForwardOnly, _
              adLockBatchOptimistic
    End With
 
    Set rst.ActiveConnection = Nothing
 
    'Ferme la conexion.
    conn.Close
 
    Set PreecheRecordSet = rst
    Exit Function
TrataErro:
    Set rst = Nothing
End Function
 
Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
 
    If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
        If sqlWhere <> vbNullString Then
            sqlWhere = sqlWhere & " AND"
        End If
        sqlWhere = sqlWhere & " UCASE(" & NomeCampo & ") LIKE UCASE('%" & Trim(Me.Controls(NomeControle).Text) & "%')"
    End If
End Sub
 
Private Function Array2DTranspose(avValues As Variant) As Variant
    Dim lThisCol As Long, lThisRow As Long
    Dim lUb2 As Long, lLb2 As Long
    Dim lUb1 As Long, lLb1 As Long
    Dim avTransposed As Variant
 
    If IsArray(avValues) Then
        On Error GoTo ErrFailed
        lUb2 = UBound(avValues, 2)
        lLb2 = LBound(avValues, 2)
        lUb1 = UBound(avValues, 1)
        lLb1 = LBound(avValues, 1)
 
        ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
        For lThisCol = lLb1 To lUb1
            For lThisRow = lLb2 To lUb2
                avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
            Next
        Next
    End If
 
    Array2DTranspose = avTransposed
    Exit Function
 
ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    Array2DTranspose = Empty
    Exit Function
    Resume
End Function