Discussion :

[azsdcv]

Bonjour à tous,

Je souhaiterai rassembler des données située dans plusieurs fichiers Excel dans un seul et unique fichier Excel. En effet, l'ouverture "manuel" de plusieurs fichiers Excel et les copier coller dans un seul fichier est extrêmement long.

Je souhaiterai donc créer une macro qui :
- dès l'ouverture du fichier Excel demande de sélectionner un autre fichier Excel
- puis me redemande si je veux ouvrir un autre fichier Excel
- pour arriver au fichier Excel regroupant les données des autre fichiers Excel

Un fichier Excel de donnée se compose de 5 colonnes A,B,C,D et E, avec un nombre de ligne variable suivant le fichier

Est-il possible de réaliser se genre de macro sans procéder à l'ouverture des fichiers Excel ?

D'avance merci pour vos réponses

Cordialement,

azsdcv

[Vadorblanc]

Bonjour
Une proposition de code que tu mets dans un module, tu lance le code qui te demande d'ouvrir ton premier fichier et qui le colle dans l'onglet 2, puis te demande d'ouvrir ton deuxième fichier et qui le colle dans ton onglet 3, ensuite tu continues et tu en fait ce que tu souhaites.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Sub Module01_Import()
 
Set Destination = ActiveWorkbook
 
Dim Msg, Style, Title, Help, Ctxt, Response, MyString, Msg1, Style1, Title1, Help1, Ctxt1, Response1, MyString1
Msg = "Ouvrir le fichier  'Au choix'?"
Style = vbYesNo + vbDefaultButton1
Title = "Ouverture du fichier source"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
 
If Response = vbYes Then
    MyString = "Yes"
 
            Source = Application.Dialogs(xlDialogOpen).Show
            If Source = False Then
            MsgBox ("Aucun fichier sélectionné")
            Exit Sub
            Else
            Set Source = ActiveWorkbook
 
 
            Source.Activate
            Sheets(1).Select
            Cells.Select 'Feuille entièrement sélectionnée
            Selection.Copy
 
            Destination.Activate 'Fichier Onglet activé
            Sheets(2).Select 'Onglet activé
            Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteValues 'Collage spécial valeurs
 
            Source.Activate 'Fichier sélectionné activé
            Application.CutCopyMode = False
            ActiveWindow.Close SaveChanges:=False 'Fichier sélectionné fermé
            End If
 
Else
MyString = "No"
MsgBox ("Aucun fichier sélectionné")
 
Exit Sub
 
End If
 
 
    Call Module01Import2 'pour passer directement au deuxième import
 
End Sub
 
 
Sub Module01Import2()
 
 
Set Destination = ActiveWorkbook
 
Dim Msg, Style, Title, Help, Ctxt, Response, MyString, Msg1, Style1, Title1, Help1, Ctxt1, Response1, MyString1
Msg = "Ouvrir le fichier 'Au choix'?"
Style = vbYesNo + vbDefaultButton1
Title = "Ouverture du fichier source"
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
 
If Response = vbYes Then
    MyString = "Yes"
 
            Source = Application.Dialogs(xlDialogOpen).Show
            If Source = False Then
            MsgBox ("Aucun fichier sélectionné")
            Exit Sub
            Else
            Set Source = ActiveWorkbook
 
            Source.Activate
            Sheets(1).Select
            Cells.Select 'Feuille entièrement sélectionnée
            Selection.Copy
 
            Destination.Activate 'Fichier Onglet activé
            Sheets(3).Select 'Onglet activé
            Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteValues 'Collage spécial valeurs
 
            Source.Activate 'Fichier sélectionné activé
            Application.CutCopyMode = False
            ActiveWindow.Close SaveChanges:=False 'Fichier sélectionné fermé
 
            End If
 
Else
MyString = "No"
MsgBox ("Aucun fichier sélectionné")
 
Exit Sub
 
End If
 
 
'Call ModuleAFairePourLaSuite
 
 
 
End Sub

Cordialement

[Theze]

Bonsoir,

Sans ouvrir les classeurs (ADO) mais en indiquant le chemin de chacun. L'arrêt de la proc se fait quand plus aucun choix n'est réalisé.
A mettre dans un module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Fichier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
    If Not IsMissing(Rs) Then
        Set Rs = CreateObject("ADODB.Recordset")
    End If
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Fichier & ";" & _
              "Extended Properties=""Excel 8.0;HDR=NO;IMEX= 2;"""
 
End Sub
 
Sub RetourPlage()
 
    Dim ConnectCL As Object
    Dim Rs As Object
    Dim Champ As Object
    Dim Tableau
    Dim Classeur As String
    Dim NomFeuille As String
    Dim Plage As String
    Dim I As Integer, J As Integer
 
    'si une erreur survient
    On Error GoTo FIN
 
    'chemin du classeur cible
    Do
 
    Classeur = Application.GetOpenFilename
 
    'si un choix à été fait
    If Classeur <> CStr(False) Then
 
        'nom de la feuille où s'effectue la récup, à adapter
        NomFeuille = "Feuil1"
 
        'toutes les cellules des colonnes A à E
        Plage = "A1:E65536"
 
        'connecte le classeur
        ConnectCLasseur ConnectCL, Classeur, Rs
 
        With Rs
 
            'récupère les valeurs dans le classeur
            .CursorType = 1
            .LockType = 3
            .Open "SELECT * FROM `" & NomFeuille & "$" & _
            Plage & "` ", ConnectCL
 
            'mets les valeurs dans un tableau (plus rapide)
            .MoveFirst
 
            ReDim Tableau( _
                1 To .RecordCount, _
                1 To .Fields.Count)
 
            .MoveFirst
 
            Do While Not .EOF
 
                I = I + 1
 
                For Each Champ In .Fields
 
                    J = J + 1
                    Tableau(I, J) = Champ.Value
 
                Next
 
                J = 0
 
                .MoveNext
 
            Loop
 
            I = 0
 
        End With
 
        'ajoute une nouvelle feuille et colle les valeurs
        'àpartir de A1
        With ThisWorkbook.Worksheets.Add
 
            .Range(.[A1], .Cells(UBound(Tableau, 1), _
            UBound(Tableau, 2))).Value = Tableau
 
        End With
 
        Erase Tableau
 
        ConnectCL.Close
 
    End If
 
    'boucle aussi longtemps qu'un choix est fait
    Loop Until Classeur = CStr(False)
 
    Set Rs = Nothing
    Set ConnectCL = Nothing
 
    Exit Sub
 
FIN:
    MsgBox "Une erreur est survenue lors de la récupération des valeurs du classeur '" & Classeur & "' !"
 
End Sub

A mettre dans le module du ThisWorkbook pour un lancement de la récup à l'ouverture du classeur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
Private Sub Workbook_Open()
 
    RetourPlage
 
End Sub

Hervé.

[Vadorblanc]

Bonjour
These, je viens de tester ta boucle qui fonctionne très bien et que je vais surement utiliser, beau travail, avec toutes les explications, de plus on a le choix aussi d'ouvrir des fichiers CSV, un grand merci.
Bien cordialement

[azsdcv]

Theze,

La macro que tu m'as proposer ne fonctionne pas. les fichiers que je souhaiterai regroupés sur une seule feuille d'un fichier Excel sont des .CSV

En effet les .XLS fonctionne très bien mais le message d'erreur apparait lorsque j'ouvre un .CSV

Est-il possible d'ajouter les valeurs des lignes copier sur une même feuille à la suite des autres valeurs ?

Encore Merci

azsdcv

[Theze]

Bonsoir,

La connexion est un peu différente pour un csv. Ci-dessous le code retouché. Les données sont maintenant misent les unes à la suite des autres dans la feuille active. Adapte le séparateur (dans l'exempe le ";" est utilisé). Reviens si ça ne va pas :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Fichier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
    If Not IsMissing(Rs) Then
        Set Rs = CreateObject("ADODB.Recordset")
    End If
 
    ConnectCL.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
                   "Dbq=" & Fichier & ";" & _
                   "Extensions=asc,csv,tab,txt;"
 
End Sub
 
Sub RetourPlage()
 
    Dim ConnectCL As Object
    Dim Rs As Object
    Dim Champ As Object
    Dim Tableau
    Dim TblSplit
    Dim Chemin As String
    Dim Classeur As String
    Dim Dossier As String
    Dim I As Integer, J As Integer, K As Integer
    Dim DerCel As Long
 
    'si une erreur survient
    On Error GoTo FIN
 
    Do
 
    'chemin du classeur cvs cible
    Chemin = Application.GetOpenFilename("Fichiers csv (*.csv), *.csv")
 
    'si un choix à été fait
    If Chemin <> CStr(False) Then
 
        'isole le nom du classeur
        Classeur = Right(Chemin, Len(Chemin) - InStrRev(Chemin, "\"))
 
        'recupère le dossier où est stocké le classeur
        Dossier = Left(Chemin, InStrRev(Chemin, "\"))
 
        'connecte le classeur
        ConnectCLasseur ConnectCL, Dossier, Rs
 
        With Rs
 
            'récupère les valeurs dans le classeur
            .CursorType = 1
            .LockType = 3
            .Open "SELECT * FROM " & Classeur, ConnectCL
 
            'mets les valeurs dans un tableau (plus rapide)
            .MoveFirst
 
            ReDim Tableau(1 To .RecordCount, 1 To 5)
 
            .MoveFirst
 
            Do While Not .EOF
 
                I = I + 1
 
                'splite l'enregistrement, adapter le séparateur (ici, le point virgule)
                TblSplit = Split(.Fields(0).Value, ";")
 
                'tranfère chaque valeur dans le tableau
                For K = 0 To UBound(TblSplit)
 
                    J = J + 1
                    Tableau(I, J) = TblSplit(K)
 
                Next
 
                J = 0
 
                .MoveNext
 
            Loop
 
            I = 0
 
        End With
 
        'colle les valeurs dans la feuille active à partir de la première cellule vide de la colonne A
        With ThisWorkbook.ActiveSheet
 
            'recherche la dernière cellule non vide, si DerCel=2 alors A1 est vide donc DerCel=1
            DerCel = .[A65536].End(xlUp).Row + 1: If DerCel = 2 Then DerCel = 1
 
            .Range(.Cells(DerCel, 1), .Cells(UBound(Tableau, 1) - 1 + DerCel, _
                   UBound(Tableau, 2))).Value = Tableau
 
        End With
 
        Erase Tableau
 
        ConnectCL.Close
 
    End If
 
    'boucle aussi longtemps qu'un choix est fait
    Loop Until Chemin = CStr(False)
 
    Set Rs = Nothing
    Set ConnectCL = Nothing
 
    Exit Sub
 
FIN:
    MsgBox "Une erreur est survenue lors de la récupération des valeurs du classeur '" & Classeur & "' !"
 
End Sub

Hervé.