VBA Access Excel

Résolu
darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   -  
 sisco -
Bonjour,
S'il quelqu'un pouvait m'aider car j'ai un gros souci.
En fait j'ai créer un fichier Excel a partir d'une table provenant d'Acces. J'aimerais pouvoir refaire de la mise en page de ce fichier mais avec une macro contenu dans Acces ou remplacer les macro pars les commandes de controles copier coller faire des lignes déplacer etc...

voici ma macro dans Excel

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 08/02/2007 par
' Replace les cases

'
If Range("B17").Value = 0 Then
Exit Sub
End If

Range("A2:J2").Select
Selection.Copy
Range("A23").Select
ActiveSheet.Paste
Range("A6:J6").Select
Application.CutCopyMode = False
Selection.Copy
Range("A24").Select
ActiveSheet.Paste
Range("A10:J10").Select
Application.CutCopyMode = False
Selection.Copy
Range("A25").Select
ActiveSheet.Paste
Range("A14:J14").Select
Application.CutCopyMode = False
Selection.Copy
Range("A26").Select
ActiveSheet.Paste
Range("A18:J18").Select
Application.CutCopyMode = False
Selection.Copy
Range("A27").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.Cut
Range("A3").Select
ActiveSheet.Paste
Range("A6").Select
Selection.Cut
Range("A7").Select
ActiveSheet.Paste
Range("A10").Select
Selection.Cut
Range("A11").Select
ActiveSheet.Paste
Range("A14").Select
Selection.Cut
Range("A15").Select
ActiveSheet.Paste
Range("A18").Select
Selection.Cut
Range("A19").Select
ActiveSheet.Paste
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Rows("5:5").Select
Selection.Delete Shift:=xlUp
Rows("8:8").Select
Selection.Delete Shift:=xlUp
Rows("11:11").Select
Selection.Delete Shift:=xlUp
Rows("14:14").Select
Selection.Delete Shift:=xlUp
Range("C4:J4").Select
Selection.ClearContents
Range("C7:J7").Select
Selection.ClearContents
Range("C10:J10").Select
Selection.ClearContents
Range("C13:J13").Select
Selection.ClearContents
Range("C16:J16").Select
Selection.ClearContents
Range("C2:J4").Select
Range("C4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("D4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("E4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("F4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("G4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("H4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("I4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C2:J4").Select
Range("J4").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("C7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("D7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("E7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("F7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("G7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("H7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("I7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C5:J7").Select
Range("J7").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("C10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("D10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("E10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("F10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("G10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("H10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("I10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C8:J10").Select
Range("J10").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("C13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("D13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("E13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("F13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("G13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("H13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("I13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C11:J13").Select
Range("J13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("C16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("D16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("E16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("F16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("G16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("H16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("I16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
Range("J16").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
Range("C14:J16").Select
End Sub

j'aimerais le faire fonctionner dans acces pour un fichier Excel externe.
Si quelqu'un peut m'aider je lui serait très reconnaissant

Merci d'avance
Configuration: Windows XP
Internet Explorer 6.0

11 réponses

  1. Sooly
     
    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
    2
  2. ptibenou
     
    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,
    0
  3. darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   1
     
    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
    0
  4. darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   1
     
    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
    0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   1
     
    Cela fonctionne presque sauf que le compilateur ne reconnais la fonction cutcopymode
    0
  7. ptibenou
     
    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!
    0
  8. darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   1
     
    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
    0
  9. ptibenou
     
    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!

    @+
    0
    1. sisco
       
      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
      0
  10. darkspoilt Messages postés 76 Date d'inscription   Statut Membre Dernière intervention   1
     
    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.
    0
  11. darkspoilt
     
    ou est ton erreur car depuis le temps j'ai résolu mon probleme.
    0
  12. sooly
     
    merci, j'ai trouvé une solution..............sous access le mot clé SELECTION ne fonction pas correctement(contrairement sou ecel marche parfaitement), il faut évite de l'utiliser en le remplacant par la zone selectionnée (range)....c tout..........je suis content!!!!
    0

Discussions similaires

Quick Access service
alain_1949 -
billmaxime -

4 réponses