Problème de transfert Access --> Excel

[Nikolas]

Bonjour,

Je souhaiterais vous poser une question. Dans une feuille Excel, j’ai déjà des données qui se trouvent dans les cellules depuis B1 jusqu’à D10. J’ai des données dans Access et je souhaite envoyer mes données à côté de D1 donc E1 mais je n’y arrive pas. Je dois d’abord envoyer mes données en respectant une cellule de décalage c'est-à-dire F1 puis supprimer la colonne E. Je souhaiterais savoir si cela est normal et est qu’il y a une solution pour éviter ça.

Voici le code que j'utilise:

Sub TransfertToExcel() 
      
        Dim db As Variant 
        Dim rs As Variant 
        Dim fichier As Variant 
        Dim stAppName As String 
        
        fichier = Application.CurrentProject.Path 
        
        Set db = DBEngine.OpenDatabase(fichier & '\\SG.mdb') 
        Set rs = db.OpenRecordset('Parc Machine', dbOpenTable) 
        
        Dim XL_App As Object 
        Set XL_App = CreateObject('Excel.Application') 
        Dim XL_classeur As Object 
        Dim XL_feuille As Object 
        Dim Rg As Range 
        Dim Nb As Long 
        Dim Sh As Worksheet 
                
        With XL_App 
            Set XL_classeur = .Workbooks.Open(fichier & '\\Inventaire.xls') 
            Set Sh = XL_classeur.Sheets('PARC SG') 
            
            With Sh 
            Set Rg = .Range('B1').End(xlToRight).Offset(0, 2) 
            End With 
                        
            Rg.CurrentRegion.Clear 
                        
            If rs.EOF = False Then 
                Nb = rs.Fields.Count - 1 

                    For a = 0 To Nb 
                        Rg(, 1 + a) = rs.Fields(a).Name 
                    Next 
                Rg.Resize(, Nb + 1).Font.Bold = Truec 
                Rg.Offset(1).CopyFromRecordset rs 
                Rg.Offset(0).CopyFromRecordset rs 
                Rg.CurrentRegion.EntireColumn.AutoFit 
                Rg.CurrentRegion.WrapText = True 
                Rg.CurrentRegion.BorderAround bordure, xlHairline, 0 
                Rg.CurrentRegion.Borders.LineStyle = xlContinuous 
                Rg.CurrentRegion.HorizontalAlignment = xlHAlignCenter 
                Rg.CurrentRegion.VerticalAlignment = xlVAlignCenter 
            Else 
                MsgBox 'Aucun enregistrement trouvé.' 
            End If 
            
            .DisplayAlerts = False 
            .ActiveWorkbook.Save 
            .ActiveWorkbook.Close 
            .DisplayAlerts = True 
            .Quit 
            
        End With 
        
        db.Close 
        XL_App.Quit 
        Set XL_App = Nothing 
        Set XL_classeur = Nothing 
        Set XL_feuille = Nothing 

End Sub

Merci par avance,

Nikolas

 

[MichelXld]

bonjour


tu peux faire un essai en remplaçant la ligne

Set Rg = .Range('B1').End(xlToRight).Offset(0, 2)

par

Set Rg = .Range('B1').End(xlToRight).Offset(0, 1)


et supprimes la ligne

Rg.CurrentRegion.Clear

si cette derniere est necessaire pour ton projet il faudra trouver une autre methode pour supprimer les données


bon apres midi
MichelXld

 

[Nikolas]

merci MichelXld pour ta réponse mais j'ai découvert ou se trouvé le problème mais je ne comprend pas pourquoi. C'est la boucle qui affiche le nom des champs comme ci-dessous qui efface mes données !! Pourriez-vous m'aider.

Nb = rs.Fields.Count - 1 
For a = 0 To Nb 
Rg(, 1 + a) = rs.Fields(a).Name 
Next a

Merci pour votre aide,

Nikolas