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
| Option Explicit
Sub WriteFileADO()
Dim PathName As String 'Chemin du dossier où la macro est présente
Dim CSVFileName As String 'nom du fichier CSV final
Dim OutputFileNum As Integer 'entier représentant le fichier
Dim NameXLSFile As String 'Format des fichier xl qui vont être lus par la macro
Dim ListeFileName As Variant 'Liste des fichiers présents dans le dossier
Dim Sheet As String 'nom de la feuille qui va être lue dans chaque fichier
Dim HeadLine As String 'entête du fichier CSV
'Initialisation des différentes variables
CSVFileName = "DICTIONNAIRE_CONTROLES_" & Format(Now, "yyyymmddhhNnSs") & ".csv"
PathName = Application.ActiveWorkbook.Path
NameXLSFile = "EVO*.xlsx"
Sheet = "PREP_CSV"
HeadLine = "Contrôle (Code);Code Type Contrôle;Code fréquence contrôle;Code Moyen Contrôle;Responsable du contrôle (Nom du contact);Code Service;Instance de donnée (Code);Code Modalité Contrôle;Contrôle (Nom);Contrôle (Description);Zone de risque;Flag Opérationnel;Flag contrôle Exhaustivité;Flag contrôle de pertinence;Flag contrôle d'exactitude;Description de la mesure (Contrôle OK si
);Seuil de tolérance 1;Seuil de tolérance 2;Rejet du flux;Rejet de l'enregistrement;Date de début;Date de fin;Contrainte ODI"
OutputFileNum = FreeFile
'Assure qu'il y a un backslash à la fin du nom du chemin
If Right(PathName, 1) <> "\" Then PathName = PathName & "\"
'Créé le fichier CSV dans le répertoire ou se trouve la macro
Open PathName & CSVFileName For Output Lock Write As #OutputFileNum
'Ecrit dans le fichier cible la première ligne qui contient les entêtes
Print #OutputFileNum, HeadLine
'Liste tous les fichers qui sont au format NameXLSFile dans le dossier ou est présente la macro
ListeFileName = Dir(PathName & NameXLSFile, vbNormal)
'Parcourt la liste de tous les fichiers
While ListeFileName <> ""
'Ecrit dans le fichier CSV cible la ligne CSV récupérée par la fonction GetCSVLine
Print #OutputFileNum, GetCSVLine(Sheet, ListeFileName)
'Passe au fichier suivant
ListeFileName = Dir
Wend
Close OutputFileNum
End Sub
Function GetCSVLine(Sheet As String, ByVal FileName As String)
'Créée un connection au fichier FileName et retourne sous forme de chaine de caractères CSV les lignes du tableau présent dans l'onglet Sheet
Dim Cn As ADODB.Connection 'objet permettant la connexion ADO au fichier FileName
Dim SQLStatement As String 'Requête SQL pour extraire les données de la feuille Sheet
Dim Recordset As ADODB.Recordset 'Résultat de la requête SQLStatement
Dim NULLStr As String 'valeur si champ vide
Dim ColDelimiter As String 'séparateur de colonne
Dim CSVLine As String 'Chaine de caractère CSV
'Initialisation des différentes variables
NULLStr = ""
ColDelimiter = ";"
SQLStatement = "SELECT * FROM [" & Sheet & "$]"
'Créé une connexion permetant d'intéroger le fichier en SQL
Set Cn = New ADODB.Connection
With Cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With
'Exécution de la requête SQLStatement
Set Recordset = New ADODB.Recordset
Set Recordset = Cn.Execute(SQLStatement)
'Récupération du résultat au format CSV
CSVLine = Recordset.GetString(adClipString, 1, ColDelimiter, , NULLStr)
Cn.Close
Set Cn = Nothing
'Renvoie le résultat
GetCSVLine = Left(CSVLine, Len(CSVLine) - 1)
End Function |
Partager