[XL-2003] Comment fusionner tous les classeurs fermés, erreur d'éxécution [Résolu]

[banyan]

Bonsoir,
La macro "Comment fusionner tous les classeurs fermés ..." donnée par SilkyRoad dans les FAQ excel correspond exactement à mon besoin. mais j'obtiens sur la ligne :

Code :

Rs.Open Cible, xConnect, adOpenStatic, adLockOptimistic, adCmdText

l'erreur suivante :

Erreur d'execution '-2147217887(80040e21)
Ce pilote ODBC ne prend pas en charge les propriétés demandées.

Débutant en VBA, mes notions se limitent à utiliser des routines du site.
Je ne sais pas du tout interpréter cette erreur.
Ci dessous la macro :

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 rassemble()
'
' rassemble Macro
' Macro enregistrée le 10/12/2011 par
''Nécessite d'activer la référence
    'Microsoft ActiveX Data Objects x.x Library
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim xConnect As String, Cible As String
Dim Fichier As String, Dossier As String, Feuille As String
Dim i As Long
 
'nom du répertoire contenant les classeurs à regrouper
Dossier = "C:\test"
'Nom de la feuille dans les classeurs fermés
'Ne pas oublier le symbole $ après le nom de la feuille
Feuille = "Données$"
i = 2
 
Fichier = Dir(Dossier & "\*.xls")
'boucle sur les fichiers du repertoire
Do While Len(Fichier) > 0
    xConnect = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
    "ReadOnly=1;DBQ=" & Dossier & "\" & Fichier
    'connection classeur
    Set Cn = New ADODB.Connection
    Cn.Open xConnect
 
    'Requete
    Cible = "SELECT * FROM [" & Feuille & "];"
 
    Set Rs = New ADODB.Recordset
    Rs.Open Cible, xConnect, adOpenStatic, adLockOptimistic, adCmdText
 
    'Ecriture dans la feuille de calcul
    If Not Rs.EOF Then Cells(i, 1).CopyFromRecordset Rs
    i = Cells(i, 1).End(xlDown).Row + 1
 
    Rs.Close
    Cn.Close
    Set Cn = Nothing
    Set Rs = Nothing
    Fichier = Dir()
Loop
 
MsgBox "Terminé"
 
End Sub

Merci pour une aide bienveillante.

[florianne]

Je ne suis pas un pro mais je suis passé moi même récemment par ces difficultés ^^

As tu bien activé les références : Microsoft ActiveX Data Objects x.x Library ?

[kiki29]

Salut, est-ce que tous les classeurs Excel dans le dossier de test ont une feuille Données ?

[banyan]

Merci de vous intérresser à mon problème:

à florianne :

- j'ai activé Microsoft ActiveX data .Objects2.8 Library

à kiki29 :

Oui tous les classeurs sont issus du même fichier XLS, seul le nom et le contenu de la sheet "Données" sont différents;

J'espère trouver la solution; en application réelle il s'agit de rassembler en un seul fichier le contenu d'une centaine de fichiers, avec un nombre de lignes de 5 à 20 par feuille "Données". Ce qui explique mon intérêt pour cette macro.
à suivre et merci d'avance.

[kiki29]

Salut, curieux, ici la macro de SilkyRoad fonctionne correctement SAUF qu'elle saute la 1ere ligne de chaque fichier , un échantillon de fichiers ( sans données confidentielles ) serait le bienvenu.

Sinon j'ai ceci , à adapter et tester dans ta configuration
Affecter un bouton à SelDossier

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
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
'-----------------------------------------------------------------------------------------------
'
'   Sous VBE Outils | References Cocher Microsoft ActiveX Data Objects 2.x Library
'                                       Microsoft Scripting Runtime
'
'-----------------------------------------------------------------------------------------------
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim NbFichiers As Long
Dim TabFichiers() As String
 
'   Paramètres à adapter
Const NomFeuille As String = "Feuil1"
Const PlageALire As String = "A1:Z65536"
Const FichierRch As String = "*.xls"
Const ColDep As Long = 2    '  Colonne B
Const RowDep As Long = 2    '  Ligne 2
 
Private Sub LireDatas(ByVal sDossier As String)
Dim NomFichier As String, Tableau As Variant
Dim i As Long, r As Long, sCol As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
 
    With Application
        .StatusBar = ""
        .ScreenUpdating = False
    End With
 
    QueryPerformanceCounter Dep
 
    Erase TabFichiers
    NbFichiers = 0
 
    ListeFichiersDansDossier sDossier, True
 
    ShDatas.Range(Cells(RowDep, 1), Cells(Rows.Count, Columns.Count)).Clear
    r = RowDep
    sCol = NumCol2Lettre(ColDep)
 
    If NbFichiers = 0 Then
        MEP
        Exit Sub
    End If
 
    For i = 1 To UBound(TabFichiers)
        NomFichier = TabFichiers(i)
        LireDonnéesADO NomFichier, NomFeuille, PlageALire, Tableau
        With ShDatas
            .Range(sCol & r, .Cells(r + UBound(Tableau, 1) - 1, UBound(Tableau, 2) + ColDep - 1)).Value = Tableau
            r = .Range(sCol & .Cells.Rows.Count).End(xlUp).Row + 1
        End With
        Application.StatusBar = i & " / " & UBound(TabFichiers)
    Next i
 
    MEP
 
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Terminé : " & Format(((Fin - Dep) / Freq), "0.00 s")
        .ScreenUpdating = True
    End With
End Sub
 
Private Sub LireDonnéesADO(ByVal Fichier As String, ByVal Feuille As String, _
                           ByVal Plage As String, ByRef TableauDatas As Variant)
Dim Conn As ADODB.Connection, Cmd As ADODB.Command
Dim Rs As ADODB.Recordset
Dim Ligne As Long, Colonne As Long
 
    Set Conn = New ADODB.Connection
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Fichier & ";" & _
              "Extended Properties=""Excel 8.0;HDR=No;"""
 
    Set Cmd = New ADODB.Command
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = "SELECT * FROM `" & Feuille & "$" & Plage & "`"
 
    Set Rs = New ADODB.Recordset
    Rs.Open Cmd, , adOpenKeyset, adLockOptimistic
    ReDim TableauDatas(1 To Rs.RecordCount, 1 To Rs.Fields.Count)
 
    Rs.MoveFirst
    Do While Not Rs.EOF
        For Ligne = 1 To Rs.RecordCount
            For Colonne = 0 To Rs.Fields.Count - 1
                TableauDatas(Ligne, Colonne + 1) = Rs.Fields(Colonne).Value
            Next Colonne
            Rs.MoveNext
        Next Ligne
    Loop
 
    Conn.Close
    Set Rs = Nothing
    Set Cmd = Nothing
    Set Conn = Nothing
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal sDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim sNomFichier As String
Dim VerifNom As Boolean
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(sDossierSource)
 
    For Each Fichier In DossierSource.Files
        sNomFichier = FSO.GetFileName(Fichier)
        VerifNom = UCase(sNomFichier) Like UCase(FichierRch) And sNomFichier <> ThisWorkbook.Name
        If VerifNom Then
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = Fichier
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function
 
Private Sub MEP()
    With ShDatas
        .Activate
        .Cells.ColumnWidth = 10.71
        .Columns.AutoFit
        .Range("A1").Select
    End With
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then LireDatas .SelectedItems(1)
    End With
End Sub

[banyan]

Merci beaucoup,

un peu tard pour entrer dans votre code qui dépasse de très loin mes compétences.
Ci-joint les fichiers de test de la macro

merci

a demain

[florianne]

Pour ma part, la macro de silkyroad fonctionne, en faisant attention de remplir les entêtes de colonnes de la même manière sur les fichiers que l'on compile.
La première ligne ne doit pas contenir de nombre.

[banyan]

Merci,

Mes entêtes sont les mêmes et sans nombre, mais toujours la même erreur.

[kiki29]

Salut, le fichier que j'ai fourni fonctionne, moyennant les modifs suivantes

Code :

1
2
3
4
Const NomFeuille As String = "Données"
Const PlageALire As String = "A2:Z65536"
Const FichierRch As String = "Recherche Stage5*.xls"
'Const FichierRch As String = "*.xls"

On joue sur

Code :

1
2
Const ColDep As Long = 2    '  Colonne B
Const RowDep As Long = 2    '  Ligne 2

pour positionner la cellule de départ des données lues : ici B2

PS : un conseil utiliser Option Explicit car ton code c'est un peu le bazar

[banyan]

Merci beaucoup, mais je n'arrive pas au bout.
Après le choix du dossier j'obtiens une erreur: Variable non définie.

Ci-joint illustration erreur et fichier utilisé.

[kiki29]

Salut, voir http://www.developpez.net/forums/d92...cel/vba-bases/
l'utilisation du CodeName permet à l'utilisateur de modifier le nom des onglets, d'ajouter ou déplacer une feuille sans avoir à toucher au code VBA

Dans ton cas remplace ShDatas par Feuil1, par défaut dans un nouveau classeur les noms d'onglet et CodeName sont les mêmes

Deplace le code de Feuil1 dans un module standard

Modifie

Code :

Const ColDep As Long = 2    '  Colonne B

en

Code :

Const ColDep As Long = 1    '  Colonne A

[banyan]

C'est nickel. Il me reste beaucoup à apprendre.
Je pensai pouvoir utiliser simplement une macro existante, mais je vois que celà n'est pas aussi simple.
Jusqu'à ce jour j'avais réussi à me débrouiller seul en suivant les différents tutoriels et faqs.
Cette fois j'ai du solliciter le forum, et je salue l'esprit de solidarité et le dévouement dont vous faites preuve.