Copie de cellules d'un classeur à l'autre

[alidroos]

Bonjour

Je ne sais pas quel est le problème dans ce code ne fonctionne pas
Notez que je veux copier des cellules isolées

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 Option Explicit
Sub Copier()
    Dim wbkc As Workbook, wbks As Workbook, nom$, chemin$, f As Worksheet
    Dim T%, R%
    Application.ScreenUpdating = 0
    chemin = "C:\A\"
    nom = Dir(chemin & "\*.xlsx")
    Set wbkc = ThisWorkbook
    Do While nom <> ""
    Set wbks = Workbooks.Open(chemin & "\" & nom)
        For Each f In wbks.Worksheets
        R = f.UsedRange.End(xlUp).Row
        wbkc.Activate
        f.Range(Union(Range("A" & R), Range("E" & R), Range("F" & R))).Copy
        T = Cells(Rows.Count, 1).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(1).Range("A" & T).PasteSpecial xlPasteValues
 
        Next f
        nom = Dir
        wbks.Close 0
    Loop
End Sub

[mercatog]

Les Range et Cells doivent être précédés de la feuille à laquelle ils se reportent

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Copier()
Dim Nom As String, Chemin As String
Dim LastLig As Long
Dim Wbks As Workbook
Dim Sh As Worksheet
 
Application.ScreenUpdating = False
Chemin = "C:\A\"
Nom = Dir(Chemin & "\*.xlsx")
Do While Nom <> ""
    Set Wbks = Workbooks.Open(Chemin & "\" & Nom)
    For Each Sh In Wbks.Worksheets
        LastLig = Sh.UsedRange.End(xlUp).Row
        Union(Sh.Range("A" & LastLig), Sh.Range("E" & LastLig), Sh.Range("Sh" & LastLig)).Copy
        With ThisWorkbook.Worksheets(1)
            .Cells(.Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
    Next Sh
    Wbks.Close False
    Nom = Dir
Loop
End Sub

[alidroos]

Merci professeur mercatog

Permettez-moi de travailler avec moi de cette manière

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
Sub Copier()
    Dim wbkc As Workbook, Wbks As Workbook, Nom$, Chemin$, f As Worksheet
    Dim T%, R%
    Application.ScreenUpdating = 0
    Chemin = "C:\A\"
    Nom = Dir(Chemin & "\*.xlsx")
    Set wbkc = ThisWorkbook
    Do While Nom <> ""
    Set Wbks = Workbooks.Open(Chemin & "\" & Nom)
        For Each f In Wbks.Worksheets
        R = f.Cells(Rows.Count, 1).End(xlUp).Row
        wbkc.Activate
        Union(f.Range("A3:A" & R), f.Range("E3:E" & R), f.Range("F3:F" & R)).Copy
        T = Cells(Rows.Count, 1).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(1).Range("A" & T).PasteSpecial xlPasteValues
        Next f
        Nom = Dir
        Wbks.Close 0
    Loop
End Sub