[XL-2003] Copier coller avec mise forme de cellule. [Résolu]

[hobine]

Bonjour,
j'ai une fonction (voir macro ci-dessous) qui copie et colle les valeurs dans un autre classeur.
Cependant, je vaudrai savoir comment copier d'un classeur A et coller dans un classeur B en concevant le même format de fichier A i.e la même en mise des cellules (couleur...) du fichier A sur le fichier B

Cordialement

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
Sub COPIEBASEVG(chemin, feuille)
Dim Wbk As Workbook
Dim Rep As String
Dim Plage As Range
Dim tbl() As Variant
Dim i As Integer, j As Integer
Dim srange As String
 
 
Set Wbk = Workbooks.Open(chemin)
With ThisWorkbook.Worksheets("service")
    Set Plage = .Range("A1:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
 
icase = UBound(tbl, 1)
 
With Wbk.Worksheets(feuille)
    Set Plage = .Range("A8:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
jcase = UBound(tbl, 1)
kcase = UBound(tbl, 2)
 
 
For i = 1 To jcase
    For j = 1 To kcase
    ThisWorkbook.Worksheets("service").Cells(i + icase + 2, j).Value = Wbk.Worksheets(feuille).Cells(i + 7, j).Value
    Next j
Next i
 
 
 
Wbk.Close False
Set Wbk = Nothing
End Sub

[Daniel.C]

Bonjour,

Essaie (non testé) :

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
Sub COPIEBASEVG(chemin, feuille)
Dim Wbk As Workbook
Dim Rep As String
Dim Plage As Range
Dim tbl() As Variant
Dim i As Integer, j As Integer
Dim srange As String
Dim Sh As Worksheet
 
 
Set Wbk = Workbooks.Open(chemin)
With ThisWorkbook.Worksheets("service")
    Set Plage = .Range("A1:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
 
icase = UBound(tbl, 1)
 
With Wbk.Worksheets(feuille)
    Set Plage = .Range("A8:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
jcase = UBound(tbl, 1)
kcase = UBound(tbl, 2)
 
Set Sh = Wbk.Worksheets(feuille)
With ThisWorkbook.Worksheets("service")
    For i = 1 To jcase
        For j = 1 To kcase
            .Cells(i + icase + 2, j).Value = Sh.Cells(i + 7, j).Value
            Sh.Cells(i + 7, j).Copy
            .Cells(i + icase + 2, j).PasteSpecial xlPasteFormats
        Next j
    Next i
End With
 
 
Wbk.Close False
Set Wbk = Nothing
End Sub

[hobine]

Cette macro fonctionne bien par contre elle est extrêmement lente. Est-ce qu'il y aurait un moyen d'accélérer le processus?

[Daniel.C]

Regarde si tu vois une différence :

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
Sub COPIEBASEVG(chemin, feuille)
Dim Wbk As Workbook
Dim Rep As String
Dim Plage As Range
Dim tbl() As Variant
Dim i As Integer, j As Integer
Dim srange As String
Dim Sh As Worksheet
 
Dim inCalculationMode As Integer
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
 
Set Wbk = Workbooks.Open(chemin)
With ThisWorkbook.Worksheets("service")
    Set Plage = .Range("A1:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
 
icase = UBound(tbl, 1)
 
With Wbk.Worksheets(feuille)
    Set Plage = .Range("A8:DV" & .Range("A65536").End(xlUp).Row)
End With
tbl = Plage.Value
jcase = UBound(tbl, 1)
kcase = UBound(tbl, 2)
 
Set Sh = Wbk.Worksheets(feuille)
With ThisWorkbook.Worksheets("service")
    For i = 1 To jcase
        For j = 1 To kcase
            .Cells(i + icase + 2, j).Value = Sh.Cells(i + 7, j).Value
            Sh.Cells(i + 7, j).Copy
            .Cells(i + icase + 2, j).PasteSpecial xlPasteFormats
        Next j
    Next i
End With
 
 
Wbk.Close False
Set Wbk = Nothing
 
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
 
End Sub

[hobine]

L’exécution reste toujours lente

[Daniel.C]

C'est possible. La macro traite quelles plages ? C'est quoi, lent ?

[hobine]

je te dits encore une fois de plus un grand merci pour ton aide mais j'ai pu trouver la solution par moi-même, elle etait vraiment simple. Mais il m'a fallu du temps, c'est cela la magie de la programmation. je te mets la solution en dessous.

cordialement

Code :

1
2
3
4
5
6
7
8
9
10
11
12
Set Sh = Wbk.Worksheets(feuille)
With ThisWorkbook.Worksheets("service")
    For i = 1 To jcase
        For j = 1 To kcase
            .Cells(i + icase + 2, j).Value = Sh.Cells(i + 7, j).Value
          ' Sh.Cells(i + 7, j).Copy
         ' .Cells(i + icase + 2, j).PasteSpecial xlPasteFormats
            .Cells(i + icase + 2, j).Interior.ColorIndex = Sh.Cells(i + 7, j).Interior.ColorIndex
            .Cells(i + icase + 2, j).Font.ColorIndex = Sh.Cells(i + 7, j).Font.ColorIndex
        Next j
    Next i
End With