Regrouper plusieurs fichiers excel en un seul.
Bonjour,
J'ai déjà créé à l'aide des ressources à ma disposition plusieurs petites applications en VBA, rien de bien méchant mais qui comme chacun sait, facilite grandement la vie.
Aujourd'hui je cherche le moyen de compiler plusieurs fichiers excel en un seul. en farfouillant sur le web j'ai trouvé le code suivant :
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
|
Sub compiler()
'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
Dim emplacement As String
'la série à traiter. <<============ Ajouter par mes soins
emplacement = InputBox("Quelle série dois-je traiter ?" & Chr(10) & Chr(10) & "Indiquer la série : ", "Série en cours de traitement", "01")
'petit test pour éviter les soucis d'incohérence.
If Len(emplacement) <> 2 Then
MsgBox "Vous avez fait une erreur ! La série doit être renseignée avec 2 caractères ! (Exemple pour la semaine 4 saisir : 04)"
emplacement = InputBox("Quelle série dois-je traiter ?" & Chr(10) & Chr(10) & "Indiquer la série : ", "Série en cours de traitement", "01")
If Len(emplacement) <> 2 Then
MsgBox "Série incorrect à nouveau, veuillez relancer la commande svp..."
Exit Sub
End If
End If
'nom du répertoire contenant les classeurs à regrouper
Dossier = "C:\Documents and Settings\plancher\Bureau\test_quinc\" & emplacement & "\"
'Nom de la feuille dans les classeurs fermés
'Ne pas oublier le symbole $ après le nom de la feuille
Feuille = "Feuil1$"
i = 2
'permet de ne pas cumuler plusieurs fois les mêmes nomenclatures
Range("A2:L100").Delete
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 "Réception des fichiers excel terminée."
End Sub |
Au vue des commentaires et de mes premiers essais il semble fonctionner parfaitement.
Hélas il ne copie pas parfaitement. en effet bien que ce soit via une requête il manque certaines cases de certaines lignes. Ainsi il se peut qu'il copie dans le fichier de destination le premier fichier parfaitement et qu'au second la ligne 6 colonne 4 se retrouve vide alors qu'elle ne l'est pas etc..
Je ne vois pas d'où cela peut-il venir, ni ce que je peux y faire pour que cela fonctionne bien.
Je vous remercie d'avance, et si vous avez besoin d'un exemple concret et/ou d'information supplémentaire n'hésitez pas à me les demander =)
