Copie de données de plusieurs fichiers excel vers un seul fichier excel

Version imprimable

Bonjour tout le monde, j'ai un soucis dans mon code vba.

Et j'aimerais aussi s'avoir si la copie en vb me fera gagner plus de temps que celle manuellement, certes vb c'est plus pratique mais reste à comparer le temps que ça prend.

Dans un dossier, j'ai plusieurs fichier excel non vide du meme format. dont j'aimerais joindre les données dans un seul fichier pour une analyse ultérieure.

En effet je voudrais ouvrir un ou plusieurs fichiers excel ayant le même format,les copier et les coller à partir de la 3ème ligne d'un fichier récapitulatif.

J'ai effectué plusieurs tests, le tout marche bien sauf la partie de la copie. Ainsi j'ai essayé plusieurs syntaxes de copie mais en vain:

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
56
57
58
59
 
Dim wbDATA As Workbook         'fichier DATA
Dim wsDATA As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range            'plage où on copie les données
 
Set wbDATA = ThisWorkbook       'Fichier récapitulatif
Set wsDATA = wbDATA.Worksheets("DATA")  'on écrit dans la feuille DATA du fichier récapitulatif
 
' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
      vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers
 
' --- Vérifier qu'au moins un fichier à été sélectionné
      If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Erreur! Aucun fichier sélectionné."
      Exit Sub
      End If
      On Error Resume Next
 
        Application.ScreenUpdating = False
 
' --- Boucle à travers les fichiers
      For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
 
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' les instructions
            Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
            Set wsSource = wbSource.Worksheets("det")                                  'On copie les données de la feuille det
            DernLign = wbDATA.Worksheets("det").Range("A60000").End(xlUp).Row + 1    
 
            For i = 1 To 55
                wbSource.wsSource.Range("A2").Copy wbDATA.wsDATA.Range("A4")
            Next i
 
            wbSource.Close              'fermer fichier
            Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Next k
 
        Application.ScreenUpdating = True
        Application.StatusBar = False
 
End Sub
 
 
 
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function

merci de votre aide!

03/05/2018, 13h16
mercatog
1. la copie se sera comme ceci:
Code:

1 2 3 4 For i = 1 To 55 wsSource.Range("A2").Copy wsDATA.Range("A4") Next i
2. Pourquoi 55 fois la même chose
03/05/2018, 15h12
Fayrouzam
J'ai oublier de copier le bout de code suivant:
Code:

1 2 3 4 For i = 1 To 55 wsSource.Rows(i).Copy Destination:=wscopie.Rows(i) Next i
Par lequel je voudrais faire une copie des 55 colonnes une par une de la 2ème ligne et les coller respectivement à partir de la 3ème ligne. Sauf que je n'y parvient pas

Sans boucle

Code:

1
2
3
4
5
6
7
8
9
'.....
For k = 1 To UBound(vFichiers)
    Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
    Set wbSource = Workbooks.Open(vFichiers(k))                                'on ouvre le fichier
    Set wsSource = wbSource.Worksheets("det")                                          'On copie les données de la feuille det
    DernLign = wsDATA.Range("A60000").End(xlUp).Row + 1
 
    wsSource.Range("A2:A55").EntireRow.Copy wsDATA.Range("A" & DernLign)
'....

voici le nouveau code, il ne copie rien !
il ouvre les fichiers selectionnés et accomplit l'execution du programme mais ne copie rien

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
Sub Creer_Recapitulatif()
 
Dim wbDATA As Workbook         'fichier DATA
Dim wsDATA As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range            'plage où on copie les données
 
Set wbDATA = ThisWorkbook       'Fichier récapitulatif
Set wsDATA = wbDATA.Worksheets("DATA")  'on écrit dans la feuille DATA du fichier récapitulatif
 
' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
      vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers
 
' --- Vérifier qu'au moins un fichier à été sélectionné
      If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
      Exit Sub
      End If
      On Error Resume Next
 
        Application.ScreenUpdating = False
 
' --- Boucle à travers les fichiers
      For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
 
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' les instructions
            Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
            Set wsSource = wbSource.Worksheets("det")                                  'On copie les données de la feuille det
            DernLign = wbDATA.Worksheets("det").Range("A60000").End(xlUp).Row + 1     'ligne pour écrire le log des fichiers compilés
            wsSource.Range("A2:A55").EntireRow.Copy wsDATA.Range("A" & DernLign)
 
    ' - On copie les données vers le fichier Recapitulatif; à adapter
    'Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0)
        'rgRecap = Time
    'With wsSource
 
            'rgRecap.Offset(0, 1) = .Range("B7")
            'rgRecap.Offset(0, 2) = .Range("B8")
            'rgRecap.Offset(0, 3) = .Range("B10")
            'rgRecap.Offset(0, 4) = .Range("B13")
            'rgRecap.Offset(0, 5) = .Range("B14")
'End With
 
            wbSource.Close              'fermer fichier
            Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Next k
 
        Application.ScreenUpdating = True
        Application.StatusBar = False
 
End Sub
 
 
 
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function

Testé comme ceci sans problème.

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
Sub Test()
Dim wsDATA As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim k As Integer
 
vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")       'Appel de Fonction pour ouvrir fichiers
If IsArray(vFichiers) Then
    Application.ScreenUpdating = False
    Set wsDATA = ThisWorkbook.Worksheets("DATA")    
    With wsDATA
        For k = 1 To UBound(vFichiers)
            Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
            Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
            Set wsSource = wbSource.Worksheets("det")
            DernLign = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            wsSource.Range("A2:X55").Copy .Range("A" & DernLign)
 
            wbSource.Close False             'fermer fichier
            Set wbSource = Nothing
            Set wsSource = Nothing
        Next k
    End With
    Set wsDATA = Nothing
 
    Application.ScreenUpdating = True
    Application.StatusBar = False
Else
    MsgBox "Erreur! Aucun fichier sélectionné."
End If
End Sub

04/05/2018, 12h18
Fayrouzam

Oui le code marche à merveille, sauf que j'aimerais faire un collage de valeur.
Sachant que dans le fichier source des valeurs sont calculés par formule, la copie et le collage sur le fichier récapitulatif retourne des #DIV/0!
Merci
04/05/2018, 12h23
mercatog
Remplace la ligne 19 par:

Code:

.Range("A" & DernLign).Resize(54).Value = wsSource.Range("A2:X55").Value

Ou utilise PasteSpecial
Code:

1 2 wsSource.Range("A2:X55").Copy .Range("A" & DernLign).PasteSpecial xlPasteValues

Super! ça marche avec ce code:

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
 
Sub Test_copie()
Dim wsDATA As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim k As Integer
Dim drlg As Long
 
vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")       'Appel de Fonction pour ouvrir fichiers
If IsArray(vFichiers) Then
    Application.ScreenUpdating = False
    Set wsDATA = ThisWorkbook.Worksheets("DATA")
    With wsDATA
        For k = 1 To UBound(vFichiers)
            Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
            Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
            Set wsSource = wbSource.Worksheets("det")
            DernLign = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
 
            'wsSource.Range("A2:X55").Copy .Range("A" & DernLign)
            drlg = wsSource.[A65536].End(xlUp).Row
            wsSource.Range("A2:BD" & drlg).Copy
            .Range("A" & DernLign).PasteSpecial xlPasteValues
 
            wbSource.Close False             'fermer fichier
            Set wbSource = Nothing
            Set wsSource = Nothing
        Next k
    End With
    Set wsDATA = Nothing
 
    Application.ScreenUpdating = True
    Application.StatusBar = False
Else
    MsgBox "Erreur! Aucun fichier sélectionné."
End If
End Sub

Merci infiniment :D