copier une feuille excel vers un autre fichier excel en access VBA

Eureka,

J'ajoute une feuille dans mon classeur de destination (fonction trouvée sur ce site) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Public Sub ajoutfeuillexls(schemin As String, snomfeuille As String)
Dim xlappf As Excel.Application
Dim xlbookf As Excel.Workbook
 
Set xlappf = CreateObject("Excel.Application")
Set xlbookf = xlappf.Workbooks.Open(schemin)
 
xlbookf.Worksheets.Add
 
xlbookf.Worksheets("Feuil1").Name = snomfeuille
xlbookf.Save
xlappf.Quit
Set xlappf = Nothing
Set xlbookf = Nothing
 
End Sub

puis je copie les valeurs à l'aide d'un objet 'Range'. L'inconvénient, c'est que cela copie uniquement les valeurs mais pas la mise en forme.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
Private Sub cmdxls_Click()
On Error GoTo Err_cmdxls_Click
Dim xlApp1 As Excel.Application
Dim xlsheet1 As Excel.Worksheet
Dim xlBook1 As Excel.Workbook
Dim xlvalue1 As Range
Dim xlApp2 As Excel.Application
Dim xlsheet2 As Excel.Worksheet
Dim xlBook2 As Excel.Workbook
Dim xlvalue2 As Range
Dim AdresseAbsolue As String
Dim i As Integer
 
KillProcess "Excel.Exe"
 
ajoutfeuillexls "C:\test\resultat.xls", "Input"
 
Set xlApp1 = CreateObject("Excel.Application")
Set xlBook1 = xlApp1.Workbooks.Open("C:\test\donneesdepart.xls")
Set xlsheet1 = xlBook1.Worksheets("Input")
xlsheet1.Unprotect
i = xlsheet1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
Set xlvalue1 = xlsheet1.Range("A1:V" & i)
 
Set xlApp2 = CreateObject("Excel.Application")
Set xlBook2 = xlApp2.Workbooks.Open("C:\test\resultat.xls")
Set xlsheet2 = xlBook2.Worksheets("Input")
Set xlvalue2 = xlsheet2.Range("A1:V" & i)
 
xlvalue2.Value = xlvalue1.Value
 
xlBook2.Save
xlBook1.Close (False)
xlApp1.Quit
 
xlApp2.Quit
Set xlvalue1 = Nothing
Set xlBook1 = Nothing
Set xlApp1 = Nothing
Set xlsheet1 = Nothing
Set xlvalue2 = Nothing
Set xlsheet2 = Nothing
Set xlBook2 = Nothing
Set xlApp2 = Nothing
 
 
Exit_cmdxls_Click:
    Exit Sub
 
Err_cmdxls_Click:
    MsgBox err.Description & " " & err.Number
    Resume Exit_cmdxls_Click
 
End Sub

En prime, la fonction Killprocess (fonction trouvée sur ce site) que j'utilise pour vérifier qu'aucune instance Excel n'est déjà ouverte.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Public Function KillProcess(ByVal ProcessName As String) As Boolean
On Error GoTo err
    Dim svc As Object
    Dim sQuery As String
    Dim oproc
    Set svc = GetObject("winmgmts:root\cimv2")
    sQuery = "select * from win32_process where name='" & ProcessName & "'"
    For Each oproc In svc.execquery(sQuery)
        oproc.Terminate
    Next
    Set svc = Nothing
err:
Set svc = Nothing
'MsgBox err.Description & " " & err.Number & " " & err.Source
End Function