Probleme Code Export Excel

**Mickael747** · 17/07/2008, 10h05

Salut,
J'avais crée un Code VB pour un export de access vers Excel (feuille de calcul).
Le but est était donc d'exporter 31 champs sous forme de tableau de calculs. Cela fonctionnait bien.
Seulement la j'ai ajouté 15 champs sur ma base access. J'ai essayé de faire des modif ds mon code pour avoir ces 15 champs supplémentaires sur ma feuille de calcul Excel lorsque j'exporte mais cela ne fonctionne pas. QQun pourrait t'il m'aider?
Voila le code que j'essaie de modifier. Il y a 47 champs au total. J'ai donc déja remplacé "31" par "47" partout ou il y avait 31.

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
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
Private Sub Commande23_Click()
    Dim cnt As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim xlApp As New Excel.Application
    Dim xlWb As Object
    Dim xlWS As Object
 
    Dim recArray As Variant
 
    Dim strDB As Variant
    Dim fldCount As Variant
    Dim recCount As Variant
    Dim iCol As Variant
    Dim j As Variant
    Dim iRow As Variant
 
    'Set the string to the path of your Northwind database
    'strDB = "S:\496_Aircraft\Travail équipe\Soulaiman\Access_Bench\Benchmarks.mdb"
     strDB = BasePath()
    ' Open connection to the database
    On Error Resume Next
    cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDB & ";"
 
    ''When using the Access 2007 Northwind database
    ''comment the previous code and uncomment the following code.
    'cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
       '"Data Source=" & strDB & ";"
 
    ' Open recordset based on Orders table
    rst.Open "Select * From [List benchmark Requête EUR]", cnt
 
    ' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWS = xlWb.Worksheets(1)
 
    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True
 
    ' Copy field names to the first row of the worksheet
    fldCount = rst.Fields.Count
    'For j = 1 To fldCount
      For iCol = 1 To fldCount
         xlWS.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
      Next
    ' Check version of Excel
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        'EXCEL 2000,2002,2003, or 2007: Use CopyFromRecordset
 
        ' Copy the recordset to the worksheet, starting in cell A2
        xlWS.Cells(2, 1).CopyFromRecordset rst
 
        xlWS.Range("A1:AE11").Copy
        xlWS.Next.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 
        xlWS.Cells.Delete
 
        '==========================================================
 
 
    xlWS.Next.Range("A1:K47").Borders(xlDiagonalDown).LineStyle = xlNone
    xlWS.Next.Range("A1:K47").Borders(xlDiagonalUp).LineStyle = xlNone
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    'With xlWS.Next.Range ("A1:K47").Borders(xlInsideVertical)
      '  .LineStyle = xlContinuous
      '  .Weight = xlThin
      '  .ColorIndex = xlAutomatic
   ' End With
    With xlWS.Next.Range("A1:K47").Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    xlWS.Next.Range("A1:K47").Borders(xlDiagonalDown).LineStyle = xlNone
    xlWS.Next.Range("A1:K47").Borders(xlDiagonalUp).LineStyle = xlNone
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlWS.Next.Range("A1:K47").Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    xlWS.Next.Range("A1:K47").Columns("A:A").ColumnWidth = 28.86
 
 
    With xlWS.Next.Range("B3:K47")
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
 
    xlWS.Next.Range("B9:K9").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B10:K10").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B11:K11").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B12:K12").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B13:K13").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B14:K14").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B15:K15").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B16:K16").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B17:K17").NumberFormat = "0.00;[Red](0.00)"
 
    xlWS.Next.Range("B18:K18").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B19:K19").NumberFormat = "0.00;[Red](0.00)"
 
    xlWS.Next.Range("B20:K20").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B21:K21").NumberFormat = "0.00;[Red](0.00)"
 
    xlWS.Next.Range("B22:K22").NumberFormat = "0.00;[Red](0.00)"
 
    xlWS.Next.Range("B23:K23").NumberFormat = "0%;[Red](0%)"
 
    xlWS.Next.Range("B24:K24").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B25:K25").NumberFormat = "0%;[Red](0%)"
 
    xlWS.Next.Range("B26:K26").NumberFormat = "#,##0.0;[Red](#,##0.0)"
 
    xlWS.Next.Range("B27:K27").NumberFormat = "#,##0;[Red](#,##0)"
 
    xlWS.Next.Range("B28:K28").NumberFormat = "0.00;[Red](0.00)"
 
    xlWS.Next.Range("B29:K29").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B30:K30").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B31:K31").NumberFormat = "0.0%;[Red](0.0%)"
 
    xlWS.Next.Range("B32:K32").NumberFormat = "0.0%;[Red](0.0%)"
 
    With xlWS.Next.Range("A1:K2").Interior
        .ColorIndex = 37
        .Pattern = xlSolid
    End With
       xlWS.Next.Range("A1:K2").Interior.ColorIndex = 33
       xlWS.Next.Range("A1:K2").Font.Bold = True
       xlWS.Next.Range("A1:K47").Font.Name = "Arial"
       xlWS.Next.Range("A1:K47").Font.Size = 8
       xlWS.Next.Range("A1:K47").Font.Strikethrough = False
       xlWS.Next.Range("A1:K47").Font.Superscript = False
       xlWS.Next.Range("A1:K47").Font.Subscript = False
       xlWS.Next.Range("A1:K47").Font.OutlineFont = False
       xlWS.Next.Range("A1:K47").Font.Shadow = False
       xlWS.Next.Range("A1:K47").Font.Underline = xlUnderlineStyleNone
       xlWS.Next.Range("A3:A47").Font.ColorIndex = 50
 
       xlWS.Next.Range("A1:K47").Cut xlWS.Range("A1:K47")
       xlWS.Select
        '==========================================================
        'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets
 
    Else
        'EXCEL 97 or earlier: Use GetRows then copy array to Excel
 
        ' Copy recordset to an array
        recArray = rst.GetRows
        'Note: GetRows returns a 0-based array where the first
        'dimension contains fields and the second dimension
        'contains records. We will transpose this array so that
        'the first dimension contains records, allowing the
        'data to appears properly when copied to Excel
 
        ' Determine number of records
 
        recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
 
 
        ' Check the array for contents that are not valid when
        ' copying the array to an Excel worksheet
        For iCol = 0 To fldCount - 1
            For iRow = 0 To recCount - 1
                ' Take care of Date fields
                If IsDate(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = Format(recArray(iCol, iRow))
                ' Take care of OLE object fields or array fields
                ElseIf IsArray(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = "Array Field"
                End If
            Next iRow 'next record
        Next iCol 'next field
 
        ' Transpose and Copy the array to the worksheet,
        ' starting in cell A2
        xlWS.Cells(2, 1).Resize(recCount, fldCount).Value = _
            TransposeDim(recArray)
    End If
 
    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit
 
    '_________________________________________________
    'Automation :copier, coller et mise en forme.
 
    'With ActiveSheet.PageSetup
  '  .Orientation = xlLandscape
  '  End With
 
    'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    '___________________________________________________________
 
     ' Release Excel references
    Set xlWS = Nothing
    Set xlWb = Nothing
 
    Set xlApp = Nothing
 
     ' Close ADO objects
    rst.Close
    cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
 
 
End Sub
 
 
Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)
 
    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant
 
    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)
 
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X
 
    TransposeDim = tempArray
 
End Function

**bernardmichel** · 17/07/2008, 11h03

Bonjour !

Peux-tu nous donner le nom de la table que tu veux exporter sous Excel STP ?

J'en ai besoin pour te soumettre un petit bout de code sympa

**Mickael747** · 17/07/2008, 11h04

Oui La voila (c'est une requete) : List benchmark Requête EUR

**bernardmichel** · 17/07/2008, 11h20

Merci... prends garde aux noms de ce type, c'est souvent source de problème, favorises des noms simple et sans espaces.. tu peux éventuellement utiliser le caractère "_" entre chaque mot (List_benchmark_Requête_EUR) ou alors une majuscule au début de chaque mot (ListBenchmarkRequêteEur)

Toujours est-il que tu peux essayer ce code... tu colles la fonction dans un module et tu l'appelle via une commande du style : "Call ExportVersExcel" depuis un bouton de commande par exemple.

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
Public Function ExportVersExcel()
Dim xl          As Excel.Application
Dim Classeur    As Excel.Workbook
Dim db          As DAO.Database
Dim rst         As DAO.Recordset
Dim fld         As DAO.Field
Dim sql         As String
Dim intCol      As Integer
 
'   Ouverture de la requête à exporter
sql = "SELECT[List benchmark Requête EUR].* FROM[List benchmark Requête EUR]"
Set db = CurrentDb()
Set rst = db.OpenRecordset(sql)
 
'   Ouverture d'Excel
Set xl = New Excel.Application
xl.Visible = True
 
With xl
    Set Classeur = .Workbooks.Add                   ' Création d'un nouveau classeur
    Classeur.Sheets("Feuil1").Name = "Importation"  ' Renommage de la première feuille du classeur
 
    With Classeur.Sheets("Importation")             ' Transfert du nom des champs en entête de colonne
        intCol = 1
        For Each fld In rst.Fields
            .Cells(1, intCol) = fld.Name
            intCol = intCol + 1
        Next
 
        .Range("A2").CopyFromRecordset rst          ' Copie du recordset sur Excel à partir de la cellule "A2"
 
    End With
 
    'Classeur.Close
End With
 
Set xl = Nothing
rst.Close
Set rst = Nothing
Set db = Nothing
End Function