mon code vba sous access marche une fois sur deux!! je ne sais pourquoi.....J'ai besoin de votre aide
Private Sub Commande2_Click()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim xlApp As Object
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 iRow As Variant
' Set the string to the path of your Northwind database
strDB = "S:\496_Aircraft\Travail équipe\Soulaiman\Access_Bench\Benchmarks.mdb"
' Open connection to the database
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]", cnt
' Create an instance of Excel and add a workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("feuil1")
' 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 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
'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.
xlApp.Sheets("Feuil1").Range("A1:X20").Copy
xlApp.Sheets("Feuil2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.Select
Range("B16:K16").Select
Selection.NumberFormat = "0.0"
Selection.NumberFormat = "0.0%"
Range("B11:K11").Select
Selection.NumberFormat = "0.0"
Selection.NumberFormat = "0.0%"
Range("B13:K13").Select
Selection.NumberFormat = "0.0"
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1:K2").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 33
.Pattern = xlSolid
End With
Range("A3:A20").Select
Selection.Font.ColorIndex = 50
Columns("A:A").ColumnWidth = 31.29
Columns("B:B").ColumnWidth = 14
Range("A1").Select
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
exercices de vba pour excel
