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 |
Partager