VBA Importer des données texte à partir d'un fichier Xlsx Fermé *connexion ADODB
Bonjour,
Tout d'abord j'aimerai remercier SilkyRoad pour le partage de sa base de connaissance, et tout particulièrement la lecture et l'écriture dans les fichiers fermés.
J'utilise de plus en plus cette méthode dans mes développements de reporting avec la programmation de TCD et graphiques temporaires.
Cependant j'ai une question à laquelle je ne trouve pas de réponse.
Je me suis créé une petite fonction générique pour importer mes données à partir d'un fichier Xlsx. bien entendu ce fichier est structuré en base de données( Titre de colonne sur la ligne 1, mots courts, pas d'espace, pas de caractères accentués, pas de signes opératoires, et pas de caractères spéciaux)
Les arguments de la fonction sont:
P$ Path,
ff$ FileFrom,
wsf SheetFrom,
r Row ( ligne à partir de à laquelle on veut placer les données importées),
c Column (colonne à partir de la quelle on veut placer les données importées),
mFolder Optional Répertoire principal (\\Path\mFolder\),
sFolder Optional Sous-répertoire (\\Path\mFolder\SFolder),
Optional Clearcontents: si Vrai, Suppression des données éventuellement présentes dans la feuille qui va recevoir les données,
rg$ nom du champ qui sera supprimé si Optional Clearcontents: = Vrai,
La fonction Function X1cFileExists(f$) As Boolean permet tester si le fichier que l'on veut importer existe
Tout cela fonctionne très bien, mais le problème est le suivant.
si dans une des colonne une cellule contient du texte de plus de 255 caratères et que cette cellule se situe dans les 8 premières lignes du fichier importé alors tout va bien, et on pourra importer du texte de plus de 255 caratères dans les cellules de cette colonne.
si dans les 8 premières lignes de notre fichier à importer aucune cellule ne possède de texte de plus de 255 caractères, alors la dimension est figée à maximum 255 caractères pour toutes les cellules de cette colonne.
Savez-vous comment faire en sorte que le nombre de caractères ne soit pas limité, en utilisant cette méthode d'importation?
Un grand merci à ceux qui pourrons orienter mes recherches ou me donner la solution.
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
| Function X1cImportDataXlsx(P$, ff$, wsf$, wst$, r&, c&, Optional mFold$, Optional sFold$, Optional ClearContent As Boolean, Optional rg$)
'99.21-Set Parameter to import Data From Xlsx File (XlOneClick: G.Charrault Inspiration: SilkyRoad)
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim cn As ADODB.Connection
Dim SQLText As String
Dim rst As ADODB.Recordset
Dim XlsxFileFrom As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets(wst)
FileFrom = ff
If Len(FileFrom) < 5 Then FileFrom = FileFrom & ".xlsx"
If UCase(Right(FileFrom, 5)) <> ".XLSX" Then FileFrom = FileFrom & ".xlsx"
XlsxFileFrom = ""
If Right(P, 1) <> "\" Then P = P & "\"
If mFold <> "" Then
If Right(mFold, 1) <> "\" Then P = P & mFold & "\"
End If
If sFold <> "" Then
If Right(sFold, 1) <> "\" Then P = P & sFold & "\"
End If
XlsxFileFrom = P & FileFrom 'XlsxFile FullFileName
If X1cFileExists(XlsxFileFrom) = False Then
MsgBox ("file is not existing")
ErrorExit = True
Exit Function
End If
If ClearContent = True Then
ws.Select
ws.Cells.ClearContents
Else
Do While ws.Cells(r, c) <> ""
r = r + 1
Loop
End If
Set cn = New ADODB.Connection
'Code to connect Xlsx File (2007-2010)
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& XlsxFileFrom & ";Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With
' ----Une case à cocher ou checkBox (Chb_Message) dans une feuille Name: wsMenu qui permet d'afficher le chemin complet du fichier pour un debugging----
' If wsMenu.Chb_Message.Value = True Then MsgBox ("Import xlsx File From: " & XlsxFileFrom & Chr(10) & Chr(13) _
' & "SheetFrom: " & wsf & Chr(10) & Chr(13) _
' & "SheetTo: " & wst & Chr(10) & Chr(13))
'
SQLText = "SELECT * FROM [" & wsf & "$]"
Set rst = New ADODB.Recordset
Set rst = cn.Execute(SQLText)
For i = 0 To rst.Fields.Count - 1
ws.Cells(r, c + i) = rst.Fields(i).Name
Next i
ws.Cells(r + 1, c).CopyFromRecordset rst
cn.Close
Set rst = Nothing
Set wb = Nothing
Set cn = Nothing
Set ws = Nothing
End Function
Function X1cFileExists(f$) As Boolean
'99.13-Test If File Exist (XlOneClick: G.Charrault)
'This function will test and return a boolean if the xml file exist
X1cFileExists = Dir(f) <> ""
End Function |
