Re : Import ADODB - Conversion étrange
Voici la macro complète :
Option Explicit
Dim sCheminFichier As String
Dim sNomFichier As String
Sub PEL()
Dim Fichier As Variant
Dim FichierSave As Variant
Dim Conn As Object
Dim Rs As Object
Dim FSO As Object
Dim Debut As Variant
Dim SQL As String
Dim ligne As Long
Dim suiviligne As Long
Dim lignepart1 As Long
Dim lignepart2 As Long
Dim page As Long
Dim totalpel As Long
Fichier = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Sélectionnez un fichier Stock PEL au format TXT... (le nom ne doit pas contenir d'espaces)")
If Fichier = False Then Exit Sub
Application.StatusBar = ""
Debut = DateTime.TIME()
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
sCheminFichier = FSO.GetFile(Fichier).ParentFolder.Path
sNomFichier = FSO.GetFile(Fichier).Name
Set FSO = Nothing
Set Conn = CreateObject("ADODB.CONNECTION")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sCheminFichier & ";" & _
"Extended Properties=""text;" & _
"HDR=No;" & _
"FMT=Delimited;MaxScanRows=0"""
'Requête de lecture du fichier
Set Rs = CreateObject("AdoDb.Recordset")
SQL = "SELECT * FROM " & sNomFichier
Rs.Open SQL, Conn, 3, 1, 1
Application.StatusBar = "Lecture du fichier stock " & sNomFichier & " en cours - veuillez patienter"
ligne = 1
suiviligne = 1
page = 1
totalpel = 0
Sheets.Add
ActiveSheet.Name = "Part1"
Range("A:Z").Select
Range("A:Z").NumberFormat = "@"
'Lecture séquentielle du curseur
While Not (Rs.EOF)
ActiveSheet.Cells(ligne, 1) = CStr(Rs.Fields(0))
ActiveSheet.Cells(ligne, 2) = CStr(Rs.Fields(1))
ActiveSheet.Cells(ligne, 3) = CStr(Rs.Fields(2))
ActiveSheet.Cells(ligne, 4) = CStr(Rs.Fields(3))
ActiveSheet.Cells(ligne, 5) = CDbl(Rs.Fields(4))
ActiveSheet.Cells(ligne, 6) = CDbl(Rs.Fields(5))
ActiveSheet.Cells(ligne, 7) = CStr(Rs.Fields(6))
ActiveSheet.Cells(ligne, 8) = CStr(Rs.Fields(7))
ActiveSheet.Cells(ligne, 9) = CStr(Rs.Fields(8))
ActiveSheet.Cells(ligne, 10) = CStr(Rs.Fields(9))
ActiveSheet.Cells(ligne, 11) = CStr(Rs.Fields(10))
ActiveSheet.Cells(ligne, 12) = CStr(Rs.Fields(11))
ActiveSheet.Cells(ligne, 13) = Rs.Fields(12)
ActiveSheet.Cells(ligne, 14) = Rs.Fields(13)
ActiveSheet.Cells(ligne, 15) = Rs.Fields(14)
ActiveSheet.Cells(ligne, 16) = CStr(Rs.Fields(15))
ActiveSheet.Cells(ligne, 17) = CStr(Rs.Fields(16))
ActiveSheet.Cells(ligne, 18) = Rs.Fields(17)
totalpel = totalpel + 1
Rs.MoveNext
ligne = ligne + 1
If page = 1 Then
lignepart1 = ligne
Else
lignepart2 = ligne
End If
'Nouvelle feuille toutes les 65000 lignes
suiviligne = suiviligne + 1
If suiviligne = 10000 Then
suiviligne = 0
Application.StatusBar = "Lecture du fichier stock " & sNomFichier & " en cours - veuillez patienter - page " & page & " - ligne " & ligne
End If
If ligne = 65000 Then
ligne = 1
page = page + 1
Sheets.Add
ActiveSheet.Name = "Part" & page
Application.StatusBar = "Lecture du fichier stock " & sNomFichier & " en cours - veuillez patienter - page " & page '
End If
Wend
Rs.Close
Set Rs = Nothing
Conn.Close
Set Conn = Nothing
Application.StatusBar = "Mise en forme en cours - veuillez patienter..."
'Mise en forme des deux premières feuilles
Sheets("Macro").Select
Rows("1:1").Select
Selection.Copy
Sheets("Part1").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Cells.EntireColumn.AutoFit
If page > 1 Then
Sheets("Macro").Select
Rows("1:1").Select
Selection.Copy
Sheets("Part2").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Cells.EntireColumn.AutoFit
End If
Application.StatusBar = "Calcul Statistiques en cours"
'Stats globaux
Sheets("Stats").Select
Sheets("Stats").Range("C3") = totalpel
Application.StatusBar = "Statistiques OK : " & Strings.Format((DateTime.TIME() - Debut) * 100000, "0.00") & " secondes"
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Sheets("Macro").Select
'ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'Sheets("Stats").Select
Sheets("Part1").Select
'FichierSave = Application.GetSaveAsFilename("Stats-PEL-200903nn.xls", , , "Veuillez sauvergarder le classeur...")
'If FichierSave <> False Then
' ActiveWorkbook.SaveAs FichierSave
'End If
End Sub
et le fichier txt version réduite :
10228;2298;100428;439; 6,00; 4,62;19940121;04;06;00000000;20021209;20040121; 228,67; 0,00; ; 42 035,69; 6 097,96; 24 507,46;
10228;2298;101750;439; 2,50; 2,50;20050901;04;00;00000000;00000000;20090901; 225,00; 50,00;MENSUELLE ; 2 325,00; 103,75; 0,00;
10228;2298;102854;439; 4,00; 2,90;19981201;04;06;00000000;20071019;20081201; 228,67; 0,00; ; 5 883,19; 1 399,60; 15,69;
10228;2298;103001;439; 5,25; 3,84;19970114;04;06;00000000;20060106;20070114; 1 524,49; 0,00; ; 23 969,50; 5 335,71; 4 308,92;
10228;2298;103028;439; 5,25; 3,84;19970114;04;06;00000000;20060106;20070114; 304,90; 0,00; ; 5 634,02; 1 896,45; 544,54;
10228;2298;103087;439; 4,50; 3,27;20020909;04;06;00000000;20060620;20120909; 225,00; 100,00;MENSUELLE ; 24 935,00; 4 231,32; 0,00;