[ACCESS] Rqt multicritere export vers Excel

Rqt multicritere export vers Excel [ACCESS] - VB/VBA/VBS - Programmation

Marsh Posté le 17-01-2008 à 17:53:57    

Bonjour,  
 
Tout d'abord merci pour le site  
 
J'ai un créé un formulaire de recherche multicritère sous access qui filtre mon formulaire.  
Je voudrais pouvoir exporter ces données vers excel. Mais je n'exporte que le formulaire entier  
Je souhaiterai pouvoir choisir quels champs exporter lors de mon filtre.  
Mon niveau en vba ne me permet pas encore de trouver une solution.  
Toute aide est la bienvenue!  
 
PS j'ai lu le tuto de cafeine sur excel ---> http://cafeine.developpez.com/access/tutoriel/excel/  
J'ai essayer la methode automation mais ça m'extrait le formulaire entier  
 
 
 
Mon Bouton Chercher  

Code :
  1. Private Sub Commande112_Click()
  2. f = ""
  3. If Not IsNull(Me.Rréseau) And Me.Rréseau <> "" Then
  4. f = "Porteur LIKE ""*" & Me.Rréseau & "*"""
  5. End If
  6. If Not IsNull(Me.Rétat) And Me.Rétat <> "" Then
  7. If f <> "" Then
  8. f = f & " AND [Etat du dossier] = """ & Me.Rétat & """"
  9. Else
  10. f = "[Etat du dossier] = """ & Me.Rétat & """"
  11. End If
  12. End If
  13. If Not IsNull(Me.Rdate1) And Me.Rdate1 <> "" And Not IsNull(Me.Rdate2) And Me.Rdate2 <> "" Then
  14. If f <> "" Then
  15. f = f & " AND ([Date d'émission]) BETWEEN " & (Me.Rdate1) & " AND " & CLng(Me.Rdate2) & ""
  16. Else
  17. f = "CLng([Date d'émission]) BETWEEN " & CLng(Me.Rdate1) & " AND " & CLng(Me.Rdate2) & ""
  18. End If
  19. End If
  20. Me.Filter = f
  21. Me.FilterOn = True


ET pour le bouton extraction excel j'ai copié celui de "Automation" de cafeine en l'adaptant mais ça extrait tout  
 

Code :
  1. Private Sub Commande165_Click()
  2. Dim xlApp As Excel.Application
  3.     Dim xlSheet As Excel.Worksheet
  4.     Dim xlBook As Excel.Workbook
  5.     Dim I As Long, J As Long
  6.     Dim t0 As Long, t1 As Long
  7.    
  8.     t0 = Timer
  9.     Dim rec As Recordset
  10.    
  11.     Set rec = CurrentDb.OpenRecordset("Actions", dbOpenSnapshot)
  12.    
  13.     'Initialisations
  14.     Set xlApp = CreateObject("Excel.Application" )
  15.     Set xlBook = xlApp.Workbooks.Add
  16.  
  17.     'Ajouter une feuille de calcul
  18.     Set xlSheet = xlBook.Worksheets.Add
  19.     xlSheet.Name = "Tutoriel"
  20.  
  21.     ' le titre
  22.     '  écriture dans la cellule de ligne 1 et de colonne 1
  23.     xlSheet.Cells(1, 1) = "Export d'une table Access"
  24.  
  25.    
  26.     ' les entetes
  27.     '  .Fields(Index).Name renvoie le nom du champ
  28.     For J = 0 To rec.Fields.Count - 1
  29.         xlSheet.Cells(2, J + 1) = rec.Fields(J).Name
  30.         ' Nous appliquons des enrichissements de format aux cellules
  31.         With xlSheet.Cells(2, J + 1)
  32.             .Interior.ColorIndex = 15
  33.             .Interior.Pattern = xlSolid
  34.             .Borders(xlEdgeBottom).LineStyle = xlContinuous
  35.             .Borders(xlEdgeBottom).Weight = xlThin
  36.             .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
  37.             .HorizontalAlignment = xlCenter
  38.         End With
  39.     Next J
  40.    
  41.     ' recopie des données à partir de la ligne 3
  42.     I = 3
  43.     Do While Not rec.EOF
  44.         For J = 0 To rec.Fields.Count - 1
  45.             ' .Fields(Index).Type renvoie le type du champ
  46.             '   si c'est un Texte (dbText) nous insérons "'" pour
  47.             '   qu'il soit reconnu par Excel comme du Texte
  48.             If rec.Fields(J).Type = dbText Then
  49.                 xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
  50.             Else                                                     '-----> j'ai un message d'erreur (erreur 1004 = erreur defini par l'application ou par l'objet)
  51.                 xlSheet.Cells(I, J + 1) = rec.Fields(J)              '----->  et pr afficher la date je dois mettre dbdate
  52.             End If
  53.         Next J
  54.         I = I + 1
  55.         rec.MoveNext
  56.     Loop
  57.  
  58.     ' code de fermeture et libération des objets
  59.     xlBook.SaveAs "C:\Documents and Settings\Nraymond\Bureau\Feuille.xls"
  60.     xlApp.Quit
  61.     rec.Close
  62.     Set rec = Nothing
  63.     Set xlSheet = Nothing
  64.     Set xlBook = Nothing
  65.     Set xlApp = Nothing
  67.     t1 = Timer
  68.     Debug.Print I & " enregistrements", Format(t1 - t0, "0" ) & " secondes"
  71. End Sub


 
 
Je vous remercie d'avance pour votre aide

Reply

Marsh Posté le 17-01-2008 à 17:53:57   

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed