VBA Access Excel
Résolu/Fermé
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
-
9 mai 2007 à 13:37
sisco - 28 oct. 2008 à 15:34
sisco - 28 oct. 2008 à 15:34
A voir également:
- VBA Access Excel
- Liste déroulante excel - Guide
- Formule excel - Guide
- Si et excel - Guide
- Aller à la ligne excel - Guide
- Mise en forme conditionnelle excel - Guide
11 réponses
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
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
Salut,
La macro c'est toi qui l'a écrite ou elle a été générée???
Parce que pour faire cette opération je ne vois qu'une solution qui consiste à déclarer excel comme un objet dans Access et d'ouvrir l'appli par ce biais. Après il suffira de reprendre chaque ligne de ta macro pour l'objet Excel déclaré.
Je sais c'est pas clair! Mais si tu t'y connais un peu tu devrais savoir de quoi je parle.
En bref un truc du style :
Dim MyExcel As Excel.Application
Set MyExcel = New Excel.Application
MyExcel.Visible = true
MyExcel.open (MonFichierExcel)
(Macro présente plus haut en adaptant le code...)
MyExcel.Workbooks(MonFichierExcel).save
MyExcel.Close
Set MyExcel=nothing
Attention pour la première ligne du doit déclarer dans les références du projet Microsoft Excel Object Library
Bon courage,
La macro c'est toi qui l'a écrite ou elle a été générée???
Parce que pour faire cette opération je ne vois qu'une solution qui consiste à déclarer excel comme un objet dans Access et d'ouvrir l'appli par ce biais. Après il suffira de reprendre chaque ligne de ta macro pour l'objet Excel déclaré.
Je sais c'est pas clair! Mais si tu t'y connais un peu tu devrais savoir de quoi je parle.
En bref un truc du style :
Dim MyExcel As Excel.Application
Set MyExcel = New Excel.Application
MyExcel.Visible = true
MyExcel.open (MonFichierExcel)
(Macro présente plus haut en adaptant le code...)
MyExcel.Workbooks(MonFichierExcel).save
MyExcel.Close
Set MyExcel=nothing
Attention pour la première ligne du doit déclarer dans les références du projet Microsoft Excel Object Library
Bon courage,
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
1
9 mai 2007 à 14:00
9 mai 2007 à 14:00
Bah en fait je débute en VBA donc j'ai compris que une partie sinon en fait c'est ladaptation du code ou j'ai du mal en fait le code c celui qui est généré automaituqe ment par Excel.
LE truc c'est que a chaque fois ke je lance une macro dans Access je crée un fichier Excel et je dois exécuté la macro excel or je sais pas ou la stocker sinon j'ai des soucis pour l'exécuter donc j'ai compris qu'une partie.
Merci de m'aider sinon
LE truc c'est que a chaque fois ke je lance une macro dans Access je crée un fichier Excel et je dois exécuté la macro excel or je sais pas ou la stocker sinon j'ai des soucis pour l'exécuter donc j'ai compris qu'une partie.
Merci de m'aider sinon
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
1
9 mai 2007 à 14:13
9 mai 2007 à 14:13
Sinon il me faudrait juste les commande pour faire du copier coller ou insérer pour les cellules ainsi que la création de ligne c peut etre compliquer mais c'est pour mon boulot que je dois faire ca et je débuteen Access et encre plus en VBA donc j'ai des soucis
Si on peut m'aider j'en serais tres reconnaissant
Si on peut m'aider j'en serais tres reconnaissant
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
1
9 mai 2007 à 14:37
9 mai 2007 à 14:37
Cela fonctionne presque sauf que le compilateur ne reconnais la fonction cutcopymode
Re,
Pour les commandes de copier coller regarde un peu ton code c'est très clair :
Range("A2:J2").Select je sélectionne A2 à J2
Selection.Copy je copie la sélection
Range("A23").Select je sélectionne A23
ActiveSheet.Paste je colle dans la page active
Range("A6:J6").Select je sélectionne A6 à J6
Application.CutCopyMode = False je désactive le mode copier coller
Selection.Copy je copie la sélection
Range("A24").Select je sélectionne A24
ActiveSheet.Paste je colle dans la page active
...
Pour la macro d'excel tu as 2 solutions :
Soit tu appliques ce que j'ai écrit au dessus dans Access et dans ce cas tu n'auras plus de Macro sous Excel.
Soit tu crées le code de la macro Excel en même temps que l'extraction des données d'Access (mais je sais même pas comment on fait).
Si tu débutes en VBA je te conseille de laisser tomber et de te perfectionner avant de faire de telles procédures.C'est pas aussi simple que ça de programmer!
En travaillant un peu sur ton code je pourrai te donner la solution mais je ne suis pas sur que donner qqchose tout cuit permette de te faire progresser.
Tu as des tutoriels très bien construit pour apprendre le VBA alors bon courage!
Pour les commandes de copier coller regarde un peu ton code c'est très clair :
Range("A2:J2").Select je sélectionne A2 à J2
Selection.Copy je copie la sélection
Range("A23").Select je sélectionne A23
ActiveSheet.Paste je colle dans la page active
Range("A6:J6").Select je sélectionne A6 à J6
Application.CutCopyMode = False je désactive le mode copier coller
Selection.Copy je copie la sélection
Range("A24").Select je sélectionne A24
ActiveSheet.Paste je colle dans la page active
...
Pour la macro d'excel tu as 2 solutions :
Soit tu appliques ce que j'ai écrit au dessus dans Access et dans ce cas tu n'auras plus de Macro sous Excel.
Soit tu crées le code de la macro Excel en même temps que l'extraction des données d'Access (mais je sais même pas comment on fait).
Si tu débutes en VBA je te conseille de laisser tomber et de te perfectionner avant de faire de telles procédures.C'est pas aussi simple que ça de programmer!
En travaillant un peu sur ton code je pourrai te donner la solution mais je ne suis pas sur que donner qqchose tout cuit permette de te faire progresser.
Tu as des tutoriels très bien construit pour apprendre le VBA alors bon courage!
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
1
9 mai 2007 à 14:55
9 mai 2007 à 14:55
Cela j'avais compris mais il me le reconnais pas dans Access en fait je cherche a crée le lien entre Access et Excel. Ma question justement était pour ne plus avoir de macro Excel. Comment bien faire appliquer le code de la macro Excel dans Access sur un fichier Excel. Je dois le faire dans le carde de mon boulot j'ai pas vraiment le choix donc je cherche en meme temps aussi.
Merci pour l'aide en tout cas
Merci pour l'aide en tout cas
Sauf si je suis vraiment con au point de pas comprendre ce que tu demandes j'en reviens à la solution de départ :
Dim MyExcel As Excel.Application
Set MyExcel = New Excel.Application
MyExcel.Visible = true
MyExcel.open (MonFichierExcel)
Macro présente plus haut en adaptant le code, voici un exemple :
MyExcel.ActiveSheet.Range("A2:J2").Select
MyExcel.ActiveSheet.Selection.Copy
MyExcel.ActiveSheet.Range("A23").Select
MyExcel.ActiveSheet.ActiveSheet.Paste
MyExcel.ActiveSheet.Range("A6:J6").Select
MyExcel.ActiveSheet.Application.CutCopyMode = False
MyExcel.Workbooks(MonFichierExcel).save
MyExcel.Close
Set MyExcel=nothing
Si tu copie/colle le code suivant il devrait "presque" fonctionner.
Il y a certainement des adaptations à faire mais avec le debug ça devrait aller vite! Surtout n'oublie pas d'ajouter Microsoft Excel Object Library dans les références de ton projet.
Je persiste à dire que demander une solution toute faite ne t'aidera pas mais bon si tu as pas le temps!
@+
Dim MyExcel As Excel.Application
Set MyExcel = New Excel.Application
MyExcel.Visible = true
MyExcel.open (MonFichierExcel)
Macro présente plus haut en adaptant le code, voici un exemple :
MyExcel.ActiveSheet.Range("A2:J2").Select
MyExcel.ActiveSheet.Selection.Copy
MyExcel.ActiveSheet.Range("A23").Select
MyExcel.ActiveSheet.ActiveSheet.Paste
MyExcel.ActiveSheet.Range("A6:J6").Select
MyExcel.ActiveSheet.Application.CutCopyMode = False
MyExcel.Workbooks(MonFichierExcel).save
MyExcel.Close
Set MyExcel=nothing
Si tu copie/colle le code suivant il devrait "presque" fonctionner.
Il y a certainement des adaptations à faire mais avec le debug ça devrait aller vite! Surtout n'oublie pas d'ajouter Microsoft Excel Object Library dans les références de ton projet.
Je persiste à dire que demander une solution toute faite ne t'aidera pas mais bon si tu as pas le temps!
@+
salut je voudrais lire un fichier excel avec mon code vba acess mais il ne reconnait pas l'objet excel
j'ai microsoft office 2003.
voici une partie de mon code:
Private Function commande() As Double
Dim t_compt As Double
t_compt = 0
Dim t_com As New ADODB.Recordset
t_com.Open "COMMANDE", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
Dim ape As excel.Application... ici que ca bloque
.....
.....
End
j'ai microsoft office 2003.
voici une partie de mon code:
Private Function commande() As Double
Dim t_compt As Double
t_compt = 0
Dim t_com As New ADODB.Recordset
t_com.Open "COMMANDE", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
Dim ape As excel.Application... ici que ca bloque
.....
.....
End
darkspoilt
Messages postés
254
Date d'inscription
jeudi 13 janvier 2005
Statut
Membre
Dernière intervention
10 octobre 2013
1
10 mai 2007 à 09:23
10 mai 2007 à 09:23
je connais pas les objets en VBA j'ai plus l'habitude de Java ou au moins il y a une javadoc mais la j'ai justement essayéé plusieur chose comme Activeworkbook.Activesheet , workbook bref mon fichier s'ouvre j'ai tester ca fonctionnemais c pour la manipulation du fichier ou j'y arrive pas meme ta solution ne fonctionne pas. ca veut pas compliler jusqu'au bout c l'implémentation de mes fonctions qu'il me manque le reste je l'avais fait.
